diff options
| author | Nick Shipp <nick@shipp.ninja> | 2017-05-07 09:04:01 -0400 |
|---|---|---|
| committer | Nick Shipp <nick@shipp.ninja> | 2017-05-07 09:04:01 -0400 |
| commit | c012f55efda29f09179e921cf148d79deb57616e (patch) | |
| tree | ff0ad37f22622d51194cab192a2aa4b0106d7ad0 /vim/bundle/slimv/slime | |
| parent | 4ca8f6608883d230131f8a9e8b6d6c091c516049 (diff) | |
Much maturering of vim configs
Diffstat (limited to 'vim/bundle/slimv/slime')
56 files changed, 44060 insertions, 0 deletions
diff --git a/vim/bundle/slimv/slime/README.md b/vim/bundle/slimv/slime/README.md new file mode 100644 index 0000000..7ef8cd3 --- /dev/null +++ b/vim/bundle/slimv/slime/README.md @@ -0,0 +1,78 @@ +[](https://travis-ci.org/slime/slime) [](http://melpa.org/#/slime) [](http://stable.melpa.org/#/slime) + +Overview +-------- + +SLIME is the Superior Lisp Interaction Mode for Emacs. + +SLIME extends Emacs with support for interactive programming in Common +Lisp. The features are centered around slime-mode, an Emacs minor-mode that +complements the standard lisp-mode. While lisp-mode supports editing Lisp +source files, slime-mode adds support for interacting with a running Common +Lisp process for compilation, debugging, documentation lookup, and so on. + +For much more information, consult [the manual][1]. + + +Quick setup instructions +------------------------ + + 1. [Set up the MELPA repository][2], if you haven't already, and install + SLIME using `M-x package-install RET slime RET`. + + 2. Add the following lines to your `~/.emacs` file, filling in in + the appropriate filenames: + + ```el + ;; Set your lisp system and, optionally, some contribs + (setq inferior-lisp-program "/opt/sbcl/bin/sbcl") + (setq slime-contribs '(slime-fancy)) + ``` + + 3. Use `M-x slime` to fire up and connect to an inferior Lisp. SLIME will + now automatically be available in your Lisp source buffers. + +If you'd like to contribute to SLIME, you will want to instead follow +the manual's instructions on [how to install SLIME via Git][7]. + + +Contribs +-------- + +SLIME comes with additional contributed packages or "contribs". +Contribs can be selected via the `slime-contribs` list. + +The most-often used contrib is `slime-fancy`, which primarily installs a +popular set of other contributed packages. It includes a better REPL, and +many more nice features. + + +License +------- + +SLIME is free software. All files, unless explicitly stated otherwise, are +public domain. + + +Contact +------- + +If you have problems, first have a look at the list of +[known issues and workarounds][6]. + +Questions and comments are best directed to the mailing list at +`slime-devel@common-lisp.net`, but you have to [subscribe][3] first. The +mailing list archive is also available on [Gmane][4]. + +See the [CONTRIBUTING.md][5] file for instructions on how to contribute. + + + + +[1]: http://common-lisp.net/project/slime/doc/html/ +[2]: http://melpa.org/#/getting-started +[3]: http://www.common-lisp.net/project/slime/#mailinglist +[4]: http://news.gmane.org/gmane.lisp.slime.devel +[5]: https://github.com/slime/slime/blob/master/CONTRIBUTING.md +[6]: https://github.com/slime/slime/issues?labels=workaround&state=closed +[7]: http://common-lisp.net/project/slime/doc/html/Installation.html#Installing-from-Git diff --git a/vim/bundle/slimv/slime/contrib/README.md b/vim/bundle/slimv/slime/contrib/README.md new file mode 100644 index 0000000..94fd02f --- /dev/null +++ b/vim/bundle/slimv/slime/contrib/README.md @@ -0,0 +1,14 @@ +This directory contains source code which may be useful to some Slime +users. `*.el` files are Emacs Lisp source and `*.lisp` files contain +Common Lisp source code. If not otherwise stated in the file itself, +the files are placed in the Public Domain. + +The components in this directory are more or less detached from the +rest of Slime. They are essentially "add-ons". But Slime can also be +used without them. The code is maintained by the respective authors. + +See the top level README.md for how to use packages in this directory. + +Finally, the contrib `slime-fancy` is specially noteworthy, as it +represents a meta-contrib that'll load a bunch of commonly used +contribs. Look into `slime-fancy.el` to find out which. diff --git a/vim/bundle/slimv/slime/contrib/swank-arglists.lisp b/vim/bundle/slimv/slime/contrib/swank-arglists.lisp new file mode 100644 index 0000000..a9357ec --- /dev/null +++ b/vim/bundle/slimv/slime/contrib/swank-arglists.lisp @@ -0,0 +1,1615 @@ +;;; swank-arglists.lisp --- arglist related code ?? +;; +;; Authors: Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> +;; Tobias C. Rittweiler <tcr@freebits.de> +;; and others +;; +;; License: Public Domain +;; + +(in-package :swank) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (swank-require :swank-c-p-c)) + +;;;; Utilities + +(defun compose (&rest functions) + "Compose FUNCTIONS right-associatively, returning a function" + #'(lambda (x) + (reduce #'funcall functions :initial-value x :from-end t))) + +(defun length= (seq n) + "Test for whether SEQ contains N number of elements. I.e. it's equivalent + to (= (LENGTH SEQ) N), but besides being more concise, it may also be more + efficiently implemented." + (etypecase seq + (list (do ((i n (1- i)) + (list seq (cdr list))) + ((or (<= i 0) (null list)) + (and (zerop i) (null list))))) + (sequence (= (length seq) n)))) + +(declaim (inline memq)) +(defun memq (item list) + (member item list :test #'eq)) + +(defun exactly-one-p (&rest values) + "If exactly one value in VALUES is non-NIL, this value is returned. +Otherwise NIL is returned." + (let ((found nil)) + (dolist (v values) + (when v (if found + (return-from exactly-one-p nil) + (setq found v)))) + found)) + +(defun valid-operator-symbol-p (symbol) + "Is SYMBOL the name of a function, a macro, or a special-operator?" + (or (fboundp symbol) + (macro-function symbol) + (special-operator-p symbol) + (member symbol '(declare declaim)))) + +(defun function-exists-p (form) + (and (valid-function-name-p form) + (fboundp form) + t)) + +(defmacro multiple-value-or (&rest forms) + (if (null forms) + nil + (let ((first (first forms)) + (rest (rest forms))) + `(let* ((values (multiple-value-list ,first)) + (primary-value (first values))) + (if primary-value + (values-list values) + (multiple-value-or ,@rest)))))) + +(defun arglist-available-p (arglist) + (not (eql arglist :not-available))) + +(defmacro with-available-arglist ((var &rest more-vars) form &body body) + `(multiple-value-bind (,var ,@more-vars) ,form + (if (eql ,var :not-available) + :not-available + (progn ,@body)))) + + +;;;; Arglist Definition + +(defstruct (arglist (:conc-name arglist.) (:predicate arglist-p)) + provided-args ; list of the provided actual arguments + required-args ; list of the required arguments + optional-args ; list of the optional arguments + key-p ; whether &key appeared + keyword-args ; list of the keywords + rest ; name of the &rest or &body argument (if any) + body-p ; whether the rest argument is a &body + allow-other-keys-p ; whether &allow-other-keys appeared + aux-args ; list of &aux variables + any-p ; whether &any appeared + any-args ; list of &any arguments [*] + known-junk ; &whole, &environment + unknown-junk) ; unparsed stuff + +;;; +;;; [*] The &ANY lambda keyword is an extension to ANSI Common Lisp, +;;; and is only used to describe certain arglists that cannot be +;;; described in another way. +;;; +;;; &ANY is very similiar to &KEY but while &KEY is based upon +;;; the idea of a plist (key1 value1 key2 value2), &ANY is a +;;; cross between &OPTIONAL, &KEY and *FEATURES* lists: +;;; +;;; a) (&ANY :A :B :C) means that you can provide any (non-null) +;;; set consisting of the keywords `:A', `:B', or `:C' in +;;; the arglist. E.g. (:A) or (:C :B :A). +;;; +;;; (This is not restricted to keywords only, but any self-evaluating +;;; expression is allowed.) +;;; +;;; b) (&ANY (key1 v1) (key2 v2) (key3 v3)) means that you can +;;; provide any (non-null) set consisting of lists where +;;; the CAR of the list is one of `key1', `key2', or `key3'. +;;; E.g. ((key1 100) (key3 42)), or ((key3 66) (key2 23)) +;;; +;;; +;;; For example, a) let us describe the situations of EVAL-WHEN as +;;; +;;; (EVAL-WHEN (&ANY :compile-toplevel :load-toplevel :execute) &BODY body) +;;; +;;; and b) let us describe the optimization qualifiers that are valid +;;; in the declaration specifier `OPTIMIZE': +;;; +;;; (DECLARE (OPTIMIZE &ANY (compilation-speed 1) (safety 1) ...)) +;;; + +;; This is a wrapper object around anything that came from Slime and +;; could not reliably be read. +(defstruct (arglist-dummy + (:conc-name #:arglist-dummy.) + (:constructor make-arglist-dummy (string-representation))) + string-representation) + +(defun empty-arg-p (dummy) + (and (arglist-dummy-p dummy) + (zerop (length (arglist-dummy.string-representation dummy))))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter +lambda-list-keywords+ + '(&provided &required &optional &rest &key &any))) + +(defmacro do-decoded-arglist (decoded-arglist &body clauses) + (assert (loop for clause in clauses + thereis (member (car clause) +lambda-list-keywords+))) + (flet ((parse-clauses (clauses) + (let* ((size (length +lambda-list-keywords+)) + (initial (make-hash-table :test #'eq :size size)) + (main (make-hash-table :test #'eq :size size)) + (final (make-hash-table :test #'eq :size size))) + (loop for clause in clauses + for lambda-list-keyword = (first clause) + for clause-parameter = (second clause) + do + (case clause-parameter + (:initially + (setf (gethash lambda-list-keyword initial) clause)) + (:finally + (setf (gethash lambda-list-keyword final) clause)) + (t + (setf (gethash lambda-list-keyword main) clause))) + finally + (return (values initial main final))))) + (generate-main-clause (clause arglist) + (dcase clause + ((&provided (&optional arg) . body) + (let ((gensym (gensym "PROVIDED-ARG+"))) + `(dolist (,gensym (arglist.provided-args ,arglist)) + (declare (ignorable ,gensym)) + (let (,@(when arg `((,arg ,gensym)))) + ,@body)))) + ((&required (&optional arg) . body) + (let ((gensym (gensym "REQUIRED-ARG+"))) + `(dolist (,gensym (arglist.required-args ,arglist)) + (declare (ignorable ,gensym)) + (let (,@(when arg `((,arg ,gensym)))) + ,@body)))) + ((&optional (&optional arg init) . body) + (let ((optarg (gensym "OPTIONAL-ARG+"))) + `(dolist (,optarg (arglist.optional-args ,arglist)) + (declare (ignorable ,optarg)) + (let (,@(when arg + `((,arg (optional-arg.arg-name ,optarg)))) + ,@(when init + `((,init (optional-arg.default-arg ,optarg))))) + ,@body)))) + ((&key (&optional keyword arg init) . body) + (let ((keyarg (gensym "KEY-ARG+"))) + `(dolist (,keyarg (arglist.keyword-args ,arglist)) + (declare (ignorable ,keyarg)) + (let (,@(when keyword + `((,keyword (keyword-arg.keyword ,keyarg)))) + ,@(when arg + `((,arg (keyword-arg.arg-name ,keyarg)))) + ,@(when init + `((,init (keyword-arg.default-arg ,keyarg))))) + ,@body)))) + ((&rest (&optional arg body-p) . body) + `(when (arglist.rest ,arglist) + (let (,@(when arg `((,arg (arglist.rest ,arglist)))) + ,@(when body-p `((,body-p (arglist.body-p ,arglist))))) + ,@body))) + ((&any (&optional arg) . body) + (let ((gensym (gensym "REQUIRED-ARG+"))) + `(dolist (,gensym (arglist.any-args ,arglist)) + (declare (ignorable ,gensym)) + (let (,@(when arg `((,arg ,gensym)))) + ,@body))))))) + (let ((arglist (gensym "DECODED-ARGLIST+"))) + (multiple-value-bind (initially-clauses main-clauses finally-clauses) + (parse-clauses clauses) + `(let ((,arglist ,decoded-arglist)) + (block do-decoded-arglist + ,@(loop for keyword in '(&provided &required + &optional &rest &key &any) + append (cddr (gethash keyword initially-clauses)) + collect (let ((clause (gethash keyword main-clauses))) + (when clause + (generate-main-clause clause arglist))) + append (cddr (gethash keyword finally-clauses))))))))) + +;;;; Arglist Printing + +(defun undummy (x) + (if (typep x 'arglist-dummy) + (arglist-dummy.string-representation x) + (prin1-to-string x))) + +(defun print-decoded-arglist (arglist &key operator provided-args highlight) + (let ((first-space-after-operator (and operator t))) + (macrolet ((space () + ;; Kludge: When OPERATOR is not given, we don't want to + ;; print a space for the first argument. + `(if (not operator) + (setq operator t) + (progn (write-char #\space) + (if first-space-after-operator + (setq first-space-after-operator nil) + (pprint-newline :fill))))) + (with-highlighting ((&key index) &body body) + `(if (eql ,index (car highlight)) + (progn (princ "===> ") ,@body (princ " <===")) + (progn ,@body))) + (print-arglist-recursively (argl &key index) + `(if (eql ,index (car highlight)) + (print-decoded-arglist ,argl :highlight (cdr highlight)) + (print-decoded-arglist ,argl)))) + (let ((index 0)) + (pprint-logical-block (nil nil :prefix "(" :suffix ")") + (when operator + (print-arg operator) + (pprint-indent :current 1)) ; 1 due to possibly added space + (do-decoded-arglist (remove-given-args arglist provided-args) + (&provided (arg) + (space) + (print-arg arg :literal-strings t) + (incf index)) + (&required (arg) + (space) + (if (arglist-p arg) + (print-arglist-recursively arg :index index) + (with-highlighting (:index index) + (print-arg arg))) + (incf index)) + (&optional :initially + (when (arglist.optional-args arglist) + (space) + (princ '&optional))) + (&optional (arg init-value) + (space) + (if (arglist-p arg) + (print-arglist-recursively arg :index index) + (with-highlighting (:index index) + (if (null init-value) + (print-arg arg) + (format t "~:@<~A ~A~@:>" + (undummy arg) (undummy init-value))))) + (incf index)) + (&key :initially + (when (arglist.key-p arglist) + (space) + (princ '&key))) + (&key (keyword arg init) + (space) + (if (arglist-p arg) + (pprint-logical-block (nil nil :prefix "(" :suffix ")") + (prin1 keyword) (space) + (print-arglist-recursively arg :index keyword)) + (with-highlighting (:index keyword) + (cond ((and init (keywordp keyword)) + (format t "~:@<~A ~A~@:>" keyword (undummy init))) + (init + (format t "~:@<(~A ..) ~A~@:>" + (undummy keyword) (undummy init))) + ((not (keywordp keyword)) + (format t "~:@<(~S ..)~@:>" keyword)) + (t + (princ keyword)))))) + (&key :finally + (when (arglist.allow-other-keys-p arglist) + (space) + (princ '&allow-other-keys))) + (&any :initially + (when (arglist.any-p arglist) + (space) + (princ '&any))) + (&any (arg) + (space) + (print-arg arg)) + (&rest (args bodyp) + (space) + (princ (if bodyp '&body '&rest)) + (space) + (if (arglist-p args) + (print-arglist-recursively args :index index) + (with-highlighting (:index index) + (print-arg args)))) + ;; FIXME: add &UNKNOWN-JUNK? + )))))) + +(defun print-arg (arg &key literal-strings) + (let ((arg (if (arglist-dummy-p arg) + (arglist-dummy.string-representation arg) + arg))) + (if (or + (and literal-strings + (stringp arg)) + (keywordp arg)) + (prin1 arg) + (princ arg)))) + +(defun print-decoded-arglist-as-template (decoded-arglist &key + (prefix "(") (suffix ")")) + (let ((first-p t)) + (flet ((space () + (unless first-p + (write-char #\space)) + (setq first-p nil)) + (print-arg-or-pattern (arg) + (etypecase arg + (symbol (if (keywordp arg) (prin1 arg) (princ arg))) + (string (princ arg)) + (list (princ arg)) + (arglist-dummy (princ + (arglist-dummy.string-representation arg))) + (arglist (print-decoded-arglist-as-template arg))) + (pprint-newline :fill))) + (pprint-logical-block (nil nil :prefix prefix :suffix suffix) + (do-decoded-arglist decoded-arglist + (&provided ()) ; do nothing; provided args are in the buffer already. + (&required (arg) + (space) (print-arg-or-pattern arg)) + (&optional (arg) + (space) (princ "[") (print-arg-or-pattern arg) (princ "]")) + (&key (keyword arg) + (space) + (prin1 (if (keywordp keyword) keyword `',keyword)) + (space) + (print-arg-or-pattern arg) + (pprint-newline :linear)) + (&any (arg) + (space) (print-arg-or-pattern arg)) + (&rest (args) + (when (or (not (arglist.keyword-args decoded-arglist)) + (arglist.allow-other-keys-p decoded-arglist)) + (space) + (format t "~A..." args)))))))) + +(defvar *arglist-pprint-bindings* + '((*print-case* . :downcase) + (*print-pretty* . t) + (*print-circle* . nil) + (*print-readably* . nil) + (*print-level* . 10) + (*print-length* . 20) + (*print-escape* . nil))) + +(defvar *arglist-show-packages* t) + +(defmacro with-arglist-io-syntax (&body body) + (let ((package (gensym))) + `(let ((,package *package*)) + (with-standard-io-syntax + (let ((*package* (if *arglist-show-packages* + *package* + ,package))) + (with-bindings *arglist-pprint-bindings* + ,@body)))))) + +(defun decoded-arglist-to-string (decoded-arglist + &key operator highlight + print-right-margin) + (with-output-to-string (*standard-output*) + (with-arglist-io-syntax + (let ((*print-right-margin* print-right-margin)) + (print-decoded-arglist decoded-arglist + :operator operator + :highlight highlight))))) + +(defun decoded-arglist-to-template-string (decoded-arglist + &key (prefix "(") (suffix ")")) + (with-output-to-string (*standard-output*) + (with-arglist-io-syntax + (print-decoded-arglist-as-template decoded-arglist + :prefix prefix + :suffix suffix)))) + +;;;; Arglist Decoding / Encoding + +(defun decode-required-arg (arg) + "ARG can be a symbol or a destructuring pattern." + (etypecase arg + (symbol arg) + (arglist-dummy arg) + (list (decode-arglist arg)))) + +(defun encode-required-arg (arg) + (etypecase arg + (symbol arg) + (arglist (encode-arglist arg)))) + +(defstruct (keyword-arg + (:conc-name keyword-arg.) + (:constructor %make-keyword-arg)) + keyword + arg-name + default-arg) + +(defun canonicalize-default-arg (form) + (if (equalp ''nil form) + nil + form)) + +(defun make-keyword-arg (keyword arg-name default-arg) + (%make-keyword-arg :keyword keyword + :arg-name arg-name + :default-arg (canonicalize-default-arg default-arg))) + +(defun decode-keyword-arg (arg) + "Decode a keyword item of formal argument list. +Return three values: keyword, argument name, default arg." + (flet ((intern-as-keyword (arg) + (intern (etypecase arg + (symbol (symbol-name arg)) + (arglist-dummy (arglist-dummy.string-representation arg))) + keyword-package))) + (cond ((or (symbolp arg) (arglist-dummy-p arg)) + (make-keyword-arg (intern-as-keyword arg) arg nil)) + ((and (consp arg) + (consp (car arg))) + (make-keyword-arg (caar arg) + (decode-required-arg (cadar arg)) + (cadr arg))) + ((consp arg) + (make-keyword-arg (intern-as-keyword (car arg)) + (car arg) (cadr arg))) + (t + (error "Bad keyword item of formal argument list"))))) + +(defun encode-keyword-arg (arg) + (cond + ((arglist-p (keyword-arg.arg-name arg)) + ;; Destructuring pattern + (let ((keyword/name (list (keyword-arg.keyword arg) + (encode-required-arg + (keyword-arg.arg-name arg))))) + (if (keyword-arg.default-arg arg) + (list keyword/name + (keyword-arg.default-arg arg)) + (list keyword/name)))) + ((eql (intern (symbol-name (keyword-arg.arg-name arg)) + keyword-package) + (keyword-arg.keyword arg)) + (if (keyword-arg.default-arg arg) + (list (keyword-arg.arg-name arg) + (keyword-arg.default-arg arg)) + (keyword-arg.arg-name arg))) + (t + (let ((keyword/name (list (keyword-arg.keyword arg) + (keyword-arg.arg-name arg)))) + (if (keyword-arg.default-arg arg) + (list keyword/name + (keyword-arg.default-arg arg)) + (list keyword/name)))))) + +(progn + (assert (equalp (decode-keyword-arg 'x) + (make-keyword-arg :x 'x nil))) + (assert (equalp (decode-keyword-arg '(x t)) + (make-keyword-arg :x 'x t))) + (assert (equalp (decode-keyword-arg '((:x y))) + (make-keyword-arg :x 'y nil))) + (assert (equalp (decode-keyword-arg '((:x y) t)) + (make-keyword-arg :x 'y t)))) + +;;; FIXME suppliedp? +(defstruct (optional-arg + (:conc-name optional-arg.) + (:constructor %make-optional-arg)) + arg-name + default-arg) + +(defun make-optional-arg (arg-name default-arg) + (%make-optional-arg :arg-name arg-name + :default-arg (canonicalize-default-arg default-arg))) + +(defun decode-optional-arg (arg) + "Decode an optional item of a formal argument list. +Return an OPTIONAL-ARG structure." + (etypecase arg + (symbol (make-optional-arg arg nil)) + (arglist-dummy (make-optional-arg arg nil)) + (list (make-optional-arg (decode-required-arg (car arg)) + (cadr arg))))) + +(defun encode-optional-arg (optional-arg) + (if (or (optional-arg.default-arg optional-arg) + (arglist-p (optional-arg.arg-name optional-arg))) + (list (encode-required-arg + (optional-arg.arg-name optional-arg)) + (optional-arg.default-arg optional-arg)) + (optional-arg.arg-name optional-arg))) + +(progn + (assert (equalp (decode-optional-arg 'x) + (make-optional-arg 'x nil))) + (assert (equalp (decode-optional-arg '(x t)) + (make-optional-arg 'x t)))) + +(define-modify-macro nreversef () nreverse "Reverse the list in PLACE.") + +(defun decode-arglist (arglist) + "Parse the list ARGLIST and return an ARGLIST structure." + (etypecase arglist + ((eql :not-available) (return-from decode-arglist + :not-available)) + (list)) + (loop + with mode = nil + with result = (make-arglist) + for arg = (if (consp arglist) + (pop arglist) + (progn + (prog1 arglist + (setf mode '&rest + arglist nil)))) + do (cond + ((eql mode '&unknown-junk) + ;; don't leave this mode -- we don't know how the arglist + ;; after unknown lambda-list keywords is interpreted + (push arg (arglist.unknown-junk result))) + ((eql arg '&allow-other-keys) + (setf (arglist.allow-other-keys-p result) t)) + ((eql arg '&key) + (setf (arglist.key-p result) t + mode arg)) + ((memq arg '(&optional &rest &body &aux)) + (setq mode arg)) + ((memq arg '(&whole &environment)) + (setq mode arg) + (push arg (arglist.known-junk result))) + ((and (symbolp arg) + (string= (symbol-name arg) (string '#:&any))) ; may be interned + (setf (arglist.any-p result) t) ; in any *package*. + (setq mode '&any)) + ((memq arg lambda-list-keywords) + (setq mode '&unknown-junk) + (push arg (arglist.unknown-junk result))) + (t + (ecase mode + (&key + (push (decode-keyword-arg arg) + (arglist.keyword-args result))) + (&optional + (push (decode-optional-arg arg) + (arglist.optional-args result))) + (&body + (setf (arglist.body-p result) t + (arglist.rest result) arg)) + (&rest + (setf (arglist.rest result) arg)) + (&aux + (push (decode-optional-arg arg) + (arglist.aux-args result))) + ((nil) + (push (decode-required-arg arg) + (arglist.required-args result))) + ((&whole &environment) + (setf mode nil) + (push arg (arglist.known-junk result))) + (&any + (push arg (arglist.any-args result)))))) + until (null arglist) + finally (nreversef (arglist.required-args result)) + finally (nreversef (arglist.optional-args result)) + finally (nreversef (arglist.keyword-args result)) + finally (nreversef (arglist.aux-args result)) + finally (nreversef (arglist.any-args result)) + finally (nreversef (arglist.known-junk result)) + finally (nreversef (arglist.unknown-junk result)) + finally (assert (or (and (not (arglist.key-p result)) + (not (arglist.any-p result))) + (exactly-one-p (arglist.key-p result) + (arglist.any-p result)))) + finally (return result))) + +(defun encode-arglist (decoded-arglist) + (append (mapcar #'encode-required-arg + (arglist.required-args decoded-arglist)) + (when (arglist.optional-args decoded-arglist) + '(&optional)) + (mapcar #'encode-optional-arg + (arglist.optional-args decoded-arglist)) + (when (arglist.key-p decoded-arglist) + '(&key)) + (mapcar #'encode-keyword-arg + (arglist.keyword-args decoded-arglist)) + (when (arglist.allow-other-keys-p decoded-arglist) + '(&allow-other-keys)) + (when (arglist.any-args decoded-arglist) + `(&any ,@(arglist.any-args decoded-arglist))) + (cond ((not (arglist.rest decoded-arglist)) + '()) + ((arglist.body-p decoded-arglist) + `(&body ,(arglist.rest decoded-arglist))) + (t + `(&rest ,(arglist.rest decoded-arglist)))) + (when (arglist.aux-args decoded-arglist) + `(&aux ,(arglist.aux-args decoded-arglist))) + (arglist.known-junk decoded-arglist) + (arglist.unknown-junk decoded-arglist))) + +;;;; Arglist Enrichment + +(defun arglist-keywords (lambda-list) + "Return the list of keywords in ARGLIST. +As a secondary value, return whether &allow-other-keys appears." + (let ((decoded-arglist (decode-arglist lambda-list))) + (values (arglist.keyword-args decoded-arglist) + (arglist.allow-other-keys-p decoded-arglist)))) + + +(defun methods-keywords (methods) + "Collect all keywords in the arglists of METHODS. +As a secondary value, return whether &allow-other-keys appears somewhere." + (let ((keywords '()) + (allow-other-keys nil)) + (dolist (method methods) + (multiple-value-bind (kw aok) + (arglist-keywords + (swank-mop:method-lambda-list method)) + (setq keywords (remove-duplicates (append keywords kw) + :key #'keyword-arg.keyword) + allow-other-keys (or allow-other-keys aok)))) + (values keywords allow-other-keys))) + +(defun generic-function-keywords (generic-function) + "Collect all keywords in the methods of GENERIC-FUNCTION. +As a secondary value, return whether &allow-other-keys appears somewhere." + (methods-keywords + (swank-mop:generic-function-methods generic-function))) + +(defun applicable-methods-keywords (generic-function arguments) + "Collect all keywords in the methods of GENERIC-FUNCTION that are +applicable for argument of CLASSES. As a secondary value, return +whether &allow-other-keys appears somewhere." + (methods-keywords + (multiple-value-bind (amuc okp) + (swank-mop:compute-applicable-methods-using-classes + generic-function (mapcar #'class-of arguments)) + (if okp + amuc + (compute-applicable-methods generic-function arguments))))) + +(defgeneric extra-keywords (operator &rest args) + (:documentation "Return a list of extra keywords of OPERATOR (a +symbol) when applied to the (unevaluated) ARGS. +As a secondary value, return whether other keys are allowed. +As a tertiary value, return the initial sublist of ARGS that was needed +to determine the extra keywords.")) + +;;; We make sure that symbol-from-KEYWORD-using keywords come before +;;; symbol-from-arbitrary-package-using keywords. And we sort the +;;; latter according to how their home-packages relate to *PACKAGE*. +;;; +;;; Rationale is to show those key parameters first which make most +;;; sense in the current context. And in particular: to put +;;; implementation-internal stuff last. +;;; +;;; This matters tremendeously on Allegro in combination with +;;; AllegroCache as that does some evil tinkering with initargs, +;;; obfuscating the arglist of MAKE-INSTANCE. +;;; + +(defmethod extra-keywords :around (op &rest args) + (declare (ignorable op args)) + (multiple-value-bind (keywords aok enrichments) (call-next-method) + (values (sort-extra-keywords keywords) aok enrichments))) + +(defun make-package-comparator (reference-packages) + "Returns a two-argument test function which compares packages +according to their used-by relation with REFERENCE-PACKAGES. Packages +will be sorted first which appear first in the PACKAGE-USE-LIST of the +reference packages." + (let ((package-use-table (make-hash-table :test 'eq))) + ;; Walk the package dependency graph breadth-fist, and fill + ;; PACKAGE-USE-TABLE accordingly. + (loop with queue = (copy-list reference-packages) + with bfn = 0 ; Breadth-First Number + for p = (pop queue) + unless (gethash p package-use-table) + do (setf (gethash p package-use-table) (shiftf bfn (1+ bfn))) + and do (setf queue (nconc queue (copy-list (package-use-list p)))) + while queue) + #'(lambda (p1 p2) + (let ((bfn1 (gethash p1 package-use-table)) + (bfn2 (gethash p2 package-use-table))) + (cond ((and bfn1 bfn2) (<= bfn1 bfn2)) + (bfn1 bfn1) + (bfn2 nil) ; p2 is used, p1 not + (t (string<= (package-name p1) (package-name p2)))))))) + +(defun sort-extra-keywords (kwds) + (stable-sort kwds (make-package-comparator (list keyword-package *package*)) + :key (compose #'symbol-package #'keyword-arg.keyword))) + +(defun keywords-of-operator (operator) + "Return a list of KEYWORD-ARGs that OPERATOR accepts. +This function is useful for writing EXTRA-KEYWORDS methods for +user-defined functions which are declared &ALLOW-OTHER-KEYS and which +forward keywords to OPERATOR." + (with-available-arglist (arglist) (arglist-from-form (ensure-list operator)) + (values (arglist.keyword-args arglist) + (arglist.allow-other-keys-p arglist)))) + +(defmethod extra-keywords (operator &rest args) + ;; default method + (declare (ignore args)) + (let ((symbol-function (symbol-function operator))) + (if (typep symbol-function 'generic-function) + (generic-function-keywords symbol-function) + nil))) + +(defun class-from-class-name-form (class-name-form) + (when (and (listp class-name-form) + (= (length class-name-form) 2) + (eq (car class-name-form) 'quote)) + (let* ((class-name (cadr class-name-form)) + (class (find-class class-name nil))) + (when (and class + (not (swank-mop:class-finalized-p class))) + ;; Try to finalize the class, which can fail if + ;; superclasses are not defined yet + (ignore-errors (swank-mop:finalize-inheritance class))) + class))) + +(defun extra-keywords/slots (class) + (multiple-value-bind (slots allow-other-keys-p) + (if (swank-mop:class-finalized-p class) + (values (swank-mop:class-slots class) nil) + (values (swank-mop:class-direct-slots class) t)) + (let ((slot-init-keywords + (loop for slot in slots append + (mapcar (lambda (initarg) + (make-keyword-arg + initarg + (swank-mop:slot-definition-name slot) + (and (swank-mop:slot-definition-initfunction slot) + (swank-mop:slot-definition-initform slot)))) + (swank-mop:slot-definition-initargs slot))))) + (values slot-init-keywords allow-other-keys-p)))) + +(defun extra-keywords/make-instance (operator &rest args) + (declare (ignore operator)) + (unless (null args) + (let* ((class-name-form (car args)) + (class (class-from-class-name-form class-name-form))) + (when class + (multiple-value-bind (slot-init-keywords class-aokp) + (extra-keywords/slots class) + (multiple-value-bind (allocate-instance-keywords ai-aokp) + (applicable-methods-keywords + #'allocate-instance (list class)) + (multiple-value-bind (initialize-instance-keywords ii-aokp) + (ignore-errors + (applicable-methods-keywords + #'initialize-instance + (list (swank-mop:class-prototype class)))) + (multiple-value-bind (shared-initialize-keywords si-aokp) + (ignore-errors + (applicable-methods-keywords + #'shared-initialize + (list (swank-mop:class-prototype class) t))) + (values (append slot-init-keywords + allocate-instance-keywords + initialize-instance-keywords + shared-initialize-keywords) + (or class-aokp ai-aokp ii-aokp si-aokp) + (list class-name-form)))))))))) + +(defun extra-keywords/change-class (operator &rest args) + (declare (ignore operator)) + (unless (null args) + (let* ((class-name-form (car args)) + (class (class-from-class-name-form class-name-form))) + (when class + (multiple-value-bind (slot-init-keywords class-aokp) + (extra-keywords/slots class) + (declare (ignore class-aokp)) + (multiple-value-bind (shared-initialize-keywords si-aokp) + (ignore-errors + (applicable-methods-keywords + #'shared-initialize + (list (swank-mop:class-prototype class) t))) + ;; FIXME: much as it would be nice to include the + ;; applicable keywords from + ;; UPDATE-INSTANCE-FOR-DIFFERENT-CLASS, I don't really see + ;; how to do it: so we punt, always declaring + ;; &ALLOW-OTHER-KEYS. + (declare (ignore si-aokp)) + (values (append slot-init-keywords shared-initialize-keywords) + t + (list class-name-form)))))))) + +(defmethod extra-keywords ((operator (eql 'make-instance)) + &rest args) + (multiple-value-or (apply #'extra-keywords/make-instance operator args) + (call-next-method))) + +(defmethod extra-keywords ((operator (eql 'make-condition)) + &rest args) + (multiple-value-or (apply #'extra-keywords/make-instance operator args) + (call-next-method))) + +(defmethod extra-keywords ((operator (eql 'error)) + &rest args) + (multiple-value-or (apply #'extra-keywords/make-instance operator args) + (call-next-method))) + +(defmethod extra-keywords ((operator (eql 'signal)) + &rest args) + (multiple-value-or (apply #'extra-keywords/make-instance operator args) + (call-next-method))) + +(defmethod extra-keywords ((operator (eql 'warn)) + &rest args) + (multiple-value-or (apply #'extra-keywords/make-instance operator args) + (call-next-method))) + +(defmethod extra-keywords ((operator (eql 'cerror)) + &rest args) + (multiple-value-bind (keywords aok determiners) + (apply #'extra-keywords/make-instance operator + (cdr args)) + (if keywords + (values keywords aok + (cons (car args) determiners)) + (call-next-method)))) + +(defmethod extra-keywords ((operator (eql 'change-class)) + &rest args) + (multiple-value-bind (keywords aok determiners) + (apply #'extra-keywords/change-class operator (cdr args)) + (if keywords + (values keywords aok + (cons (car args) determiners)) + (call-next-method)))) + +(defun enrich-decoded-arglist-with-keywords (decoded-arglist keywords + allow-other-keys-p) + "Modify DECODED-ARGLIST using KEYWORDS and ALLOW-OTHER-KEYS-P." + (when keywords + (setf (arglist.key-p decoded-arglist) t) + (setf (arglist.keyword-args decoded-arglist) + (remove-duplicates + (append (arglist.keyword-args decoded-arglist) + keywords) + :key #'keyword-arg.keyword))) + (setf (arglist.allow-other-keys-p decoded-arglist) + (or (arglist.allow-other-keys-p decoded-arglist) + allow-other-keys-p))) + +(defun enrich-decoded-arglist-with-extra-keywords (decoded-arglist form) + "Determine extra keywords from the function call FORM, and modify +DECODED-ARGLIST to include them. As a secondary return value, return +the initial sublist of ARGS that was needed to determine the extra +keywords. As a tertiary return value, return whether any enrichment +was done." + (multiple-value-bind (extra-keywords extra-aok determining-args) + (apply #'extra-keywords form) + ;; enrich the list of keywords with the extra keywords + (enrich-decoded-arglist-with-keywords decoded-arglist + extra-keywords extra-aok) + (values decoded-arglist + determining-args + (or extra-keywords extra-aok)))) + +(defgeneric compute-enriched-decoded-arglist (operator-form argument-forms) + (:documentation + "Return three values: DECODED-ARGLIST, DETERMINING-ARGS, and +ANY-ENRICHMENT, just like enrich-decoded-arglist-with-extra-keywords. +If the arglist is not available, return :NOT-AVAILABLE.")) + +(defmethod compute-enriched-decoded-arglist (operator-form argument-forms) + (with-available-arglist (decoded-arglist) + (decode-arglist (arglist operator-form)) + (enrich-decoded-arglist-with-extra-keywords decoded-arglist + (cons operator-form + argument-forms)))) + +(defmethod compute-enriched-decoded-arglist + ((operator-form (eql 'with-open-file)) argument-forms) + (declare (ignore argument-forms)) + (multiple-value-bind (decoded-arglist determining-args) + (call-next-method) + (let ((first-arg (first (arglist.required-args decoded-arglist))) + (open-arglist (compute-enriched-decoded-arglist 'open nil))) + (when (and (arglist-p first-arg) (arglist-p open-arglist)) + (enrich-decoded-arglist-with-keywords + first-arg + (arglist.keyword-args open-arglist) + nil))) + (values decoded-arglist determining-args t))) + +(defmethod compute-enriched-decoded-arglist ((operator-form (eql 'apply)) + argument-forms) + (let ((function-name-form (car argument-forms))) + (when (and (listp function-name-form) + (length= function-name-form 2) + (memq (car function-name-form) '(quote function))) + (let ((function-name (cadr function-name-form))) + (when (valid-operator-symbol-p function-name) + (let ((function-arglist + (compute-enriched-decoded-arglist function-name + (cdr argument-forms)))) + (return-from compute-enriched-decoded-arglist + (values + (make-arglist :required-args + (list 'function) + :optional-args + (append + (mapcar #'(lambda (arg) + (make-optional-arg arg nil)) + (arglist.required-args function-arglist)) + (arglist.optional-args function-arglist)) + :key-p + (arglist.key-p function-arglist) + :keyword-args + (arglist.keyword-args function-arglist) + :rest + 'args + :allow-other-keys-p + (arglist.allow-other-keys-p function-arglist)) + (list function-name-form) + t))))))) + (call-next-method)) + +(defmethod compute-enriched-decoded-arglist + ((operator-form (eql 'multiple-value-call)) argument-forms) + (compute-enriched-decoded-arglist 'apply argument-forms)) + +(defun delete-given-args (decoded-arglist args) + "Delete given ARGS from DECODED-ARGLIST." + (macrolet ((pop-or-return (list) + `(if (null ,list) + (return-from do-decoded-arglist) + (pop ,list)))) + (do-decoded-arglist decoded-arglist + (&provided () + (assert (eq (pop-or-return args) + (pop (arglist.provided-args decoded-arglist))))) + (&required () + (pop-or-return args) + (pop (arglist.required-args decoded-arglist))) + (&optional () + (pop-or-return args) + (pop (arglist.optional-args decoded-arglist))) + (&key (keyword) + ;; N.b. we consider a keyword to be given only when the keyword + ;; _and_ a value has been given for it. + (loop for (key value) on args by #'cddr + when (and (eq keyword key) value) + do (setf (arglist.keyword-args decoded-arglist) + (remove keyword (arglist.keyword-args decoded-arglist) + :key #'keyword-arg.keyword)))))) + decoded-arglist) + +(defun remove-given-args (decoded-arglist args) + ;; FIXME: We actually needa deep copy here. + (delete-given-args (copy-arglist decoded-arglist) args)) + +;;;; Arglist Retrieval + +(defun arglist-from-form (form) + (if (null form) + :not-available + (arglist-dispatch (car form) (cdr form)))) + +(export 'arglist-dispatch) +(defgeneric arglist-dispatch (operator arguments) + ;; Default method + (:method (operator arguments) + (unless (and (symbolp operator) (valid-operator-symbol-p operator)) + (return-from arglist-dispatch :not-available)) + + (multiple-value-bind (decoded-arglist determining-args) + (compute-enriched-decoded-arglist operator arguments) + (with-available-arglist (arglist) decoded-arglist + ;; replace some formal args by determining actual args + (setf arglist (delete-given-args arglist determining-args)) + (setf (arglist.provided-args arglist) determining-args) + arglist)))) + +(defmethod arglist-dispatch ((operator (eql 'defmethod)) arguments) + (match (cons operator arguments) + (('defmethod (#'function-exists-p gf-name) . rest) + (let ((gf (fdefinition gf-name))) + (when (typep gf 'generic-function) + (with-available-arglist (arglist) (decode-arglist (arglist gf)) + (let ((qualifiers (loop for x in rest + until (or (listp x) (empty-arg-p x)) + collect x))) + (return-from arglist-dispatch + (make-arglist :provided-args (cons gf-name qualifiers) + :required-args (list arglist) + :rest "body" :body-p t))))))) + (_)) ; Fall through + (call-next-method)) + +(defmethod arglist-dispatch ((operator (eql 'define-compiler-macro)) arguments) + (match (cons operator arguments) + (('define-compiler-macro (#'function-exists-p gf-name) . _) + (let ((gf (fdefinition gf-name))) + (with-available-arglist (arglist) (decode-arglist (arglist gf)) + (return-from arglist-dispatch + (make-arglist :provided-args (list gf-name) + :required-args (list arglist) + :rest "body" :body-p t))))) + (_)) ; Fall through + (call-next-method)) + + +(defmethod arglist-dispatch ((operator (eql 'eval-when)) arguments) + (declare (ignore arguments)) + (let ((eval-when-args '(:compile-toplevel :load-toplevel :execute))) + (make-arglist + :required-args (list (make-arglist :any-p t :any-args eval-when-args)) + :rest '#:body :body-p t))) + + +(defmethod arglist-dispatch ((operator (eql 'declare)) arguments) + (let* ((declaration (cons operator (last arguments))) + (typedecl-arglist (arglist-for-type-declaration declaration))) + (if (arglist-available-p typedecl-arglist) + typedecl-arglist + (match declaration + (('declare ((#'consp typespec) . decl-args)) + (with-available-arglist (typespec-arglist) + (decoded-arglist-for-type-specifier typespec) + (make-arglist + :required-args (list (make-arglist + :required-args (list typespec-arglist) + :rest '#:variables))))) + (('declare (decl-identifier . decl-args)) + (decoded-arglist-for-declaration decl-identifier decl-args)) + (_ (make-arglist :rest '#:declaration-specifiers)))))) + +(defmethod arglist-dispatch ((operator (eql 'declaim)) arguments) + (arglist-dispatch 'declare arguments)) + + +(defun arglist-for-type-declaration (declaration) + (flet ((%arglist-for-type-declaration (identifier typespec rest-var-name) + (with-available-arglist (typespec-arglist) + (decoded-arglist-for-type-specifier typespec) + (make-arglist + :required-args (list (make-arglist + :provided-args (list identifier) + :required-args (list typespec-arglist) + :rest rest-var-name)))))) + (match declaration + (('declare ('type (#'consp typespec) . decl-args)) + (%arglist-for-type-declaration 'type typespec '#:variables)) + (('declare ('ftype (#'consp typespec) . decl-args)) + (%arglist-for-type-declaration 'ftype typespec '#:function-names)) + (('declare ((#'consp typespec) . decl-args)) + (with-available-arglist (typespec-arglist) + (decoded-arglist-for-type-specifier typespec) + (make-arglist + :required-args (list (make-arglist + :required-args (list typespec-arglist) + :rest '#:variables))))) + (_ :not-available)))) + +(defun decoded-arglist-for-declaration (decl-identifier decl-args) + (declare (ignore decl-args)) + (with-available-arglist (arglist) + (decode-arglist (declaration-arglist decl-identifier)) + (setf (arglist.provided-args arglist) (list decl-identifier)) + (make-arglist :required-args (list arglist)))) + +(defun decoded-arglist-for-type-specifier (type-specifier) + (etypecase type-specifier + (arglist-dummy :not-available) + (cons (decoded-arglist-for-type-specifier (car type-specifier))) + (symbol + (with-available-arglist (arglist) + (decode-arglist (type-specifier-arglist type-specifier)) + (setf (arglist.provided-args arglist) (list type-specifier)) + arglist)))) + +;;; Slimefuns + +;;; We work on a RAW-FORM, or BUFFER-FORM, which represent the form at +;;; user's point in Emacs. A RAW-FORM looks like +;;; +;;; ("FOO" ("BAR" ...) "QUUX" ("ZURP" SWANK::%CURSOR-MARKER%)) +;;; +;;; The expression before the cursor marker is the expression where +;;; user's cursor points at. An explicit marker is necessary to +;;; disambiguate between +;;; +;;; ("IF" ("PRED") +;;; ("F" "X" "Y" %CURSOR-MARKER%)) +;;; +;;; and +;;; ("IF" ("PRED") +;;; ("F" "X" "Y") %CURSOR-MARKER%) + +;;; Notice that for a form like (FOO (BAR |) QUUX), where | denotes +;;; user's point, the following should be sent ("FOO" ("BAR" "" +;;; %CURSOR-MARKER%)). Only the forms up to point should be +;;; considered. + +(defslimefun autodoc (raw-form &key print-right-margin) + "Return a list of two elements. +First, a string representing the arglist for the deepest subform in +RAW-FORM that does have an arglist. The highlighted parameter is +wrapped in ===> X <===. + +Second, a boolean value telling whether the returned string can be cached." + (handler-bind ((serious-condition + #'(lambda (c) + (unless (debug-on-swank-error) + (let ((*print-right-margin* print-right-margin)) + (return-from autodoc + (format nil "Arglist Error: \"~A\"" c))))))) + (with-buffer-syntax () + (multiple-value-bind (form arglist obj-at-cursor form-path) + (find-subform-with-arglist (parse-raw-form raw-form)) + (cond ((boundp-and-interesting obj-at-cursor) + (list (print-variable-to-string obj-at-cursor) nil)) + (t + (list + (with-available-arglist (arglist) arglist + (decoded-arglist-to-string + arglist + :print-right-margin print-right-margin + :operator (car form) + :highlight (form-path-to-arglist-path form-path + form + arglist))) + t))))))) + +(defun boundp-and-interesting (symbol) + (and symbol + (symbolp symbol) + (boundp symbol) + (not (memq symbol '(cl:t cl:nil))) + (not (keywordp symbol)))) + +(defun print-variable-to-string (symbol) + "Return a short description of VARIABLE-NAME, or NIL." + (let ((*print-pretty* t) (*print-level* 4) + (*print-length* 10) (*print-lines* 1) + (*print-readably* nil) + (value (symbol-value symbol))) + (call/truncated-output-to-string + 75 (lambda (s) + (without-printing-errors (:object value :stream s) + (format s "~A ~A~S" symbol *echo-area-prefix* value)))))) + + +(defslimefun complete-form (raw-form) + "Read FORM-STRING in the current buffer package, then complete it + by adding a template for the missing arguments." + ;; We do not catch errors here because COMPLETE-FORM is an + ;; interactive command, not automatically run in the background like + ;; ARGLIST-FOR-ECHO-AREA. + (with-buffer-syntax () + (multiple-value-bind (arglist provided-args) + (find-immediately-containing-arglist (parse-raw-form raw-form)) + (with-available-arglist (arglist) arglist + (decoded-arglist-to-template-string + (delete-given-args arglist + (remove-if #'empty-arg-p provided-args + :from-end t :count 1)) + :prefix "" :suffix ""))))) + +(defslimefun completions-for-keyword (keyword-string raw-form) + "Return a list of possible completions for KEYWORD-STRING relative +to the context provided by RAW-FORM." + (with-buffer-syntax () + (let ((arglist (find-immediately-containing-arglist + (parse-raw-form raw-form)))) + (when (arglist-available-p arglist) + ;; It would be possible to complete keywords only if we are in + ;; a keyword position, but it is not clear if we want that. + (let* ((keywords + (append (mapcar #'keyword-arg.keyword + (arglist.keyword-args arglist)) + (remove-if-not #'keywordp (arglist.any-args arglist)))) + (keyword-name + (tokenize-symbol keyword-string)) + (matching-keywords + (find-matching-symbols-in-list + keyword-name keywords (make-compound-prefix-matcher #\-))) + (converter (completion-output-symbol-converter keyword-string)) + (strings + (mapcar converter + (mapcar #'symbol-name matching-keywords))) + (completion-set + (format-completion-set strings nil ""))) + (list completion-set + (longest-compound-prefix completion-set))))))) + +(defparameter +cursor-marker+ '%cursor-marker%) + +(defun find-subform-with-arglist (form) + "Returns four values: + + The appropriate subform of `form' which is closest to the + +CURSOR-MARKER+ and whose operator is valid and has an + arglist. The +CURSOR-MARKER+ is removed from that subform. + + Second value is the arglist. Local function and macro definitions + appearing in `form' into account. + + Third value is the object in front of +CURSOR-MARKER+. + + Fourth value is a form path to that object." + (labels + ((yield-success (form local-ops) + (multiple-value-bind (form obj-at-cursor form-path) + (extract-cursor-marker form) + (values form + (let ((entry (assoc (car form) local-ops :test #'op=))) + (if entry + (decode-arglist (cdr entry)) + (arglist-from-form form))) + obj-at-cursor + form-path))) + (yield-failure () + (values nil :not-available)) + (operator-p (operator local-ops) + (or (and (symbolp operator) (valid-operator-symbol-p operator)) + (assoc operator local-ops :test #'op=))) + (op= (op1 op2) + (cond ((and (symbolp op1) (symbolp op2)) + (eq op1 op2)) + ((and (arglist-dummy-p op1) (arglist-dummy-p op2)) + (string= (arglist-dummy.string-representation op1) + (arglist-dummy.string-representation op2))))) + (grovel-form (form local-ops) + "Descend FORM top-down, always taking the rightest branch, + until +CURSOR-MARKER+." + (assert (listp form)) + (destructuring-bind (operator . args) form + ;; N.b. the user's cursor is at the rightmost, deepest + ;; subform right before +CURSOR-MARKER+. + (let ((last-subform (car (last form))) + (new-ops)) + (cond + ((eq last-subform +cursor-marker+) + (if (operator-p operator local-ops) + (yield-success form local-ops) + (yield-failure))) + ((not (operator-p operator local-ops)) + (grovel-form last-subform local-ops)) + ;; Make sure to pick up the arglists of local + ;; function/macro definitions. + ((setq new-ops (extract-local-op-arglists operator args)) + (multiple-value-or (grovel-form last-subform + (nconc new-ops local-ops)) + (yield-success form local-ops))) + ;; Some typespecs clash with function names, so we make + ;; sure to bail out early. + ((member operator '(cl:declare cl:declaim)) + (yield-success form local-ops)) + ;; Mostly uninteresting, hence skip. + ((memq operator '(cl:quote cl:function)) + (yield-failure)) + (t + (multiple-value-or (grovel-form last-subform local-ops) + (yield-success form local-ops)))))))) + (if (null form) + (yield-failure) + (grovel-form form '())))) + +(defun extract-cursor-marker (form) + "Returns three values: normalized `form' without +CURSOR-MARKER+, +the object in front of +CURSOR-MARKER+, and a form path to that +object." + (labels ((grovel (form last path) + (let ((result-form)) + (loop for (car . cdr) on form do + (cond ((eql car +cursor-marker+) + (decf (first path)) + (return-from grovel + (values (nreconc result-form cdr) + last + (nreverse path)))) + ((consp car) + (multiple-value-bind (new-car new-last new-path) + (grovel car last (cons 0 path)) + (when new-path ; CAR contained cursor-marker? + (return-from grovel + (values (nreconc + (cons new-car result-form) cdr) + new-last + new-path)))))) + (push car result-form) + (setq last car) + (incf (first path)) + finally + (return-from grovel + (values (nreverse result-form) nil nil)))))) + (grovel form nil (list 0)))) + +(defgeneric extract-local-op-arglists (operator args) + (:documentation + "If the form `(OPERATOR ,@ARGS) is a local operator binding form, + return a list of pairs (OP . ARGLIST) for each locally bound op.") + (:method (operator args) + (declare (ignore operator args)) + nil) + ;; FLET + (:method ((operator (eql 'cl:flet)) args) + (let ((defs (first args)) + (body (rest args))) + (cond ((null body) nil) ; `(flet ((foo (x) |' + ((atom defs) nil) ; `(flet ,foo (|' + (t (%collect-op/argl-alist defs))))) + ;; LABELS + (:method ((operator (eql 'cl:labels)) args) + ;; Notice that we only have information to "look backward" and + ;; show arglists of previously occuring local functions. + (destructuring-bind (defs . body) args + (unless (or (atom defs) (null body)) ; `(labels ,foo (|' + (let ((current-def (car (last defs)))) + (cond ((atom current-def) nil) ; `(labels ((foo (x) ...)|' + ((not (null body)) + (extract-local-op-arglists 'cl:flet args)) + (t + (let ((def.body (cddr current-def))) + (when def.body + (%collect-op/argl-alist defs))))))))) + ;; MACROLET + (:method ((operator (eql 'cl:macrolet)) args) + (extract-local-op-arglists 'cl:labels args))) + +(defun %collect-op/argl-alist (defs) + (setq defs (remove-if-not #'(lambda (x) + ;; Well-formed FLET/LABELS def? + (and (consp x) (second x))) + defs)) + (loop for (name arglist . nil) in defs + collect (cons name arglist))) + +(defun find-immediately-containing-arglist (form) + "Returns the arglist of the subform _immediately_ containing ++CURSOR-MARKER+ in `form'. Notice, however, that +CURSOR-MARKER+ may +be in a nested arglist \(e.g. `(WITH-OPEN-FILE (<here>'\), and the +arglist of the appropriate parent form \(WITH-OPEN-FILE\) will be +returned in that case." + (flet ((try (form-path form arglist) + (let* ((arglist-path (form-path-to-arglist-path form-path + form + arglist)) + (argl (apply #'arglist-ref + arglist + arglist-path)) + (args (apply #'provided-arguments-ref + (cdr form) + arglist + arglist-path))) + (when (and (arglist-p argl) (listp args)) + (values argl args))))) + (multiple-value-bind (form arglist obj form-path) + (find-subform-with-arglist form) + (declare (ignore obj)) + (with-available-arglist (arglist) arglist + ;; First try the form the cursor is in (in case of a normal + ;; form), then try the surrounding form (in case of a nested + ;; macro form). + (multiple-value-or (try form-path form arglist) + (try (butlast form-path) form arglist) + :not-available))))) + +(defun form-path-to-arglist-path (form-path form arglist) + "Convert a form path to an arglist path consisting of arglist +indices." + (labels ((convert (path args arglist) + (if (null path) + nil + (let* ((idx (car path)) + (idx* (arglist-index idx args arglist)) + (arglist* (and idx* (arglist-ref arglist idx*))) + (args* (and idx* (provided-arguments-ref args + arglist + idx*)))) + ;; The FORM-PATH may be more detailed than ARGLIST; + ;; consider (defun foo (x y) ...), a form path may + ;; point into the function's lambda-list, but the + ;; arglist of DEFUN won't contain as much information. + ;; So we only recurse if possible. + (cond ((null idx*) + nil) + ((arglist-p arglist*) + (cons idx* (convert (cdr path) args* arglist*))) + (t + (list idx*))))))) + (convert + ;; FORM contains irrelevant operator. Adjust FORM-PATH. + (cond ((null form-path) nil) + ((equal form-path '(0)) nil) + (t + (destructuring-bind (car . cdr) form-path + (cons (1- car) cdr)))) + (cdr form) + arglist))) + +(defun arglist-index (provided-argument-index provided-arguments arglist) + "Return the arglist index into `arglist' for the parameter belonging +to the argument (NTH `provided-argument-index' `provided-arguments')." + (let ((positional-args# (positional-args-number arglist)) + (arg-index provided-argument-index)) + (with-struct (arglist. key-p rest) arglist + (cond + ((< arg-index positional-args#) ; required + optional + arg-index) + ((and (not key-p) (not rest)) ; more provided than allowed + nil) + ((not key-p) ; rest + body + (assert (arglist.rest arglist)) + positional-args#) + (t ; key + ;; Find last provided &key parameter + (let* ((argument (nth arg-index provided-arguments)) + (provided-keys (subseq provided-arguments positional-args#))) + (loop for (key value) on provided-keys by #'cddr + when (eq value argument) + return (match key + (('quote symbol) symbol) + (_ key))))))))) + +(defun arglist-ref (arglist &rest indices) + "Returns the parameter in ARGLIST along the INDICIES path. Numbers +represent positional parameters (required, optional), keywords +represent key parameters." + (flet ((ref-positional-arg (arglist index) + (check-type index (integer 0 *)) + (with-struct (arglist. provided-args required-args + optional-args rest) + arglist + (loop for args in (list provided-args required-args + (mapcar #'optional-arg.arg-name + optional-args)) + for args# = (length args) + if (< index args#) + return (nth index args) + else + do (decf index args#) + finally (return (or rest nil))))) + (ref-keyword-arg (arglist keyword) + ;; keyword argument may be any symbol, + ;; not only from the KEYWORD package. + (let ((keyword (match keyword + (('quote symbol) symbol) + (_ keyword)))) + (do-decoded-arglist arglist + (&key (kw arg) (when (eq kw keyword) + (return-from ref-keyword-arg arg))))) + nil)) + (dolist (index indices) + (assert (arglist-p arglist)) + (setq arglist (if (numberp index) + (ref-positional-arg arglist index) + (ref-keyword-arg arglist index)))) + arglist)) + +(defun provided-arguments-ref (provided-args arglist &rest indices) + "Returns the argument in PROVIDED-ARGUMENT along the INDICES path +relative to ARGLIST." + (check-type arglist arglist) + (flet ((ref (provided-args arglist index) + (if (numberp index) + (nth index provided-args) + (let ((provided-keys (subseq provided-args + (positional-args-number arglist)))) + (loop for (key value) on provided-keys + when (eq key index) + return value))))) + (dolist (idx indices) + (setq provided-args (ref provided-args arglist idx)) + (setq arglist (arglist-ref arglist idx))) + provided-args)) + +(defun positional-args-number (arglist) + (+ (length (arglist.provided-args arglist)) + (length (arglist.required-args arglist)) + (length (arglist.optional-args arglist)))) + +(defun parse-raw-form (raw-form) + "Parse a RAW-FORM into a Lisp form. I.e. substitute strings by +symbols if already interned. For strings not already interned, use +ARGLIST-DUMMY." + (unless (null raw-form) + (loop for element in raw-form + collect (etypecase element + (string (read-conversatively element)) + (list (parse-raw-form element)) + (symbol (prog1 element + ;; Comes after list, so ELEMENT can't be NIL. + (assert (eq element +cursor-marker+)))))))) + +(defun read-conversatively (string) + "Tries to find the symbol that's represented by STRING. + +If it can't, this either means that STRING does not represent a +symbol, or that the symbol behind STRING would have to be freshly +interned. Because this function is supposed to be called from the +automatic arglist display stuff from Slime, interning freshly +symbols is a big no-no. + +In such a case (that no symbol could be found), an object of type +ARGLIST-DUMMY is returned instead, which works as a placeholder +datum for subsequent logics to rely on." + (let* ((string (string-left-trim '(#\Space #\Tab #\Newline) string)) + (length (length string)) + (type (cond ((zerop length) nil) + ((eql (aref string 0) #\') + :quoted-symbol) + ((search "#'" string :end2 (min length 2)) + :sharpquoted-symbol) + ((char= (char string 0) (char string (1- length)) + #\") + :string) + (t + :symbol)))) + (multiple-value-bind (symbol found?) + (case type + (:symbol (parse-symbol string)) + (:quoted-symbol (parse-symbol (subseq string 1))) + (:sharpquoted-symbol (parse-symbol (subseq string 2))) + (:string (values string t)) + (t (values string nil))) + (if found? + (ecase type + (:symbol symbol) + (:quoted-symbol `(quote ,symbol)) + (:sharpquoted-symbol `(function ,symbol)) + (:string (if (> length 1) + (subseq string 1 (1- length)) + string))) + (make-arglist-dummy string))))) + +(defun test-print-arglist () + (flet ((test (arglist &rest strings) + (let* ((*package* (find-package :swank)) + (actual (decoded-arglist-to-string + (decode-arglist arglist) + :print-right-margin 1000))) + (unless (loop for string in strings + thereis (string= actual string)) + (warn "Test failed: ~S => ~S~% Expected: ~A" + arglist actual + (if (cdr strings) + (format nil "One of: ~{~S~^, ~}" strings) + (format nil "~S" (first strings)))))))) + (test '(function cons) "(function cons)") + (test '(quote cons) "(quote cons)") + (test '(&key (function #'+)) + "(&key (function #'+))" "(&key (function (function +)))") + (test '(&whole x y z) "(y z)") + (test '(x &aux y z) "(x)") + (test '(x &environment env y) "(x y)") + (test '(&key ((function f))) "(&key ((function ..)))") + (test + '(eval-when (&any :compile-toplevel :load-toplevel :execute) &body body) + "(eval-when (&any :compile-toplevel :load-toplevel :execute) &body body)") + (test '(declare (optimize &any (speed 1) (safety 1))) + "(declare (optimize &any (speed 1) (safety 1)))"))) + +(defun test-arglist-ref () + (macrolet ((soft-assert (form) + `(unless ,form + (warn "Assertion failed: ~S~%" ',form)))) + (let ((sample (decode-arglist '(x &key ((:k (y z))))))) + (soft-assert (eq (arglist-ref sample 0) 'x)) + (soft-assert (eq (arglist-ref sample :k 0) 'y)) + (soft-assert (eq (arglist-ref sample :k 1) 'z)) + + (soft-assert (eq (provided-arguments-ref '(a :k (b c)) sample 0) + 'a)) + (soft-assert (eq (provided-arguments-ref '(a :k (b c)) sample :k 0) + 'b)) + (soft-assert (eq (provided-arguments-ref '(a :k (b c)) sample :k 1) + 'c))))) + +(test-print-arglist) +(test-arglist-ref) + +(provide :swank-arglists) diff --git a/vim/bundle/slimv/slime/contrib/swank-asdf.lisp b/vim/bundle/slimv/slime/contrib/swank-asdf.lisp new file mode 100644 index 0000000..2bcedd0 --- /dev/null +++ b/vim/bundle/slimv/slime/contrib/swank-asdf.lisp @@ -0,0 +1,536 @@ +;;; swank-asdf.lisp -- ASDF support +;; +;; Authors: Daniel Barlow <dan@telent.net> +;; Marco Baringer <mb@bese.it> +;; Edi Weitz <edi@agharta.de> +;; Francois-Rene Rideau <tunes@google.com> +;; and others +;; License: Public Domain +;; + +(in-package :swank) + +(eval-when (:compile-toplevel :load-toplevel :execute) +;;; The best way to load ASDF is from an init file of an +;;; implementation. If ASDF is not loaded at the time swank-asdf is +;;; loaded, it will be tried first with (require "asdf"), if that +;;; doesn't help and *asdf-path* is set, it will be loaded from that +;;; file. +;;; To set *asdf-path* put the following into ~/.swank.lisp: +;;; (defparameter swank::*asdf-path* #p"/path/to/asdf/asdf.lisp") + (defvar *asdf-path* nil + "Path to asdf.lisp file, to be loaded in case (require \"asdf\") fails.")) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (member :asdf *features*) + (ignore-errors (funcall 'require "asdf")))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (member :asdf *features*) + (handler-bind ((warning #'muffle-warning)) + (when *asdf-path* + (load *asdf-path* :if-does-not-exist nil))))) + +;; If still not found, error out. +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (member :asdf *features*) + (error "Could not load ASDF. +Please update your implementation or +install a recent release of ASDF and in your ~~/.swank.lisp specify: + (defparameter swank::*asdf-path* #p\"/path/containing/asdf/asdf.lisp\")"))) + +;;; If ASDF is too old, punt. +;; As of January 2014, Quicklisp has been providing 2.26 for a year +;; (and previously had 2.014.6 for over a year), whereas +;; all SLIME-supported implementations provide ASDF3 (i.e. 2.27 or later) +;; except LispWorks (stuck with 2.019) and SCL (which hasn't been released +;; in years and doesn't provide ASDF at all, but is fully supported by ASDF). +;; If your implementation doesn't provide ASDF, or provides an old one, +;; install an upgrade yourself and configure *asdf-path*. +;; It's just not worth the hassle supporting something +;; that doesn't even have COERCE-PATHNAME. +;; +;; NB: this version check is duplicated in swank-loader.lisp so that we don't +;; try to load this contrib when ASDF is too old since that will abort the SLIME +;; connection. +#-asdf3 +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (or #+asdf3 t #+asdf2 + (asdf:version-satisfies (asdf:asdf-version) "2.14.6")) + (error "Your ASDF is too old. ~ + The oldest version supported by swank-asdf is 2.014.6."))) +;;; Import functionality from ASDF that isn't available in all ASDF versions. +;;; Please do NOT depend on any of the below as reference: +;;; they are sometimes stripped down versions, for compatibility only. +;;; Indeed, they are supposed to work on *OLDER*, not *NEWER* versions of ASDF. +;;; +;;; The way I got these is usually by looking at the current definition, +;;; using git blame in one screen to locate which commit last modified it, +;;; and git log in another to determine which release that made it in. +;;; It is OK for some of the below definitions to be or become obsolete, +;;; as long as it will make do with versions older than the tagged version: +;;; if ASDF is more recent, its more recent version will win. +;;; +;;; If your software is hacking ASDF, use its internals. +;;; If you want ASDF utilities in user software, please use ASDF-UTILS. + +(defun asdf-at-least (version) + (asdf:version-satisfies (asdf:asdf-version) version)) + +(defmacro asdefs (version &rest defs) + (flet ((defun* (version name aname rest) + `(progn + (defun ,name ,@rest) + (declaim (notinline ,name)) + (when (asdf-at-least ,version) + (setf (fdefinition ',name) (fdefinition ',aname))))) + (defmethod* (version aname rest) + `(unless (asdf-at-least ,version) + (defmethod ,aname ,@rest))) + (defvar* (name aname rest) + `(progn + (define-symbol-macro ,name ,aname) + (defvar ,aname ,@rest)))) + `(progn + ,@(loop :for (def name . args) :in defs + :for aname = (intern (string name) :asdf) + :collect + (ecase def + ((defun) (defun* version name aname args)) + ((defmethod) (defmethod* version aname args)) + ((defvar) (defvar* name aname args))))))) + +(asdefs "2.15" + (defvar *wild* #-cormanlisp :wild #+cormanlisp "*") + + (defun collect-asds-in-directory (directory collect) + (map () collect (directory-asd-files directory))) + + (defun register-asd-directory (directory &key recurse exclude collect) + (if (not recurse) + (collect-asds-in-directory directory collect) + (collect-sub*directories-asd-files + directory :exclude exclude :collect collect)))) + +(asdefs "2.16" + (defun load-sysdef (name pathname) + (declare (ignore name)) + (let ((package (asdf::make-temporary-package))) + (unwind-protect + (let ((*package* package) + (*default-pathname-defaults* + (asdf::pathname-directory-pathname + (translate-logical-pathname pathname)))) + (asdf::asdf-message + "~&; Loading system definition from ~A into ~A~%" ; + pathname package) + (load pathname)) + (delete-package package)))) + + (defun directory* (pathname-spec &rest keys &key &allow-other-keys) + (apply 'directory pathname-spec + (append keys + '#.(or #+allegro + '(:directories-are-files nil + :follow-symbolic-links nil) + #+clozure + '(:follow-links nil) + #+clisp + '(:circle t :if-does-not-exist :ignore) + #+(or cmu scl) + '(:follow-links nil :truenamep nil) + #+sbcl + (when (find-symbol "RESOLVE-SYMLINKS" '#:sb-impl) + '(:resolve-symlinks nil))))))) +(asdefs "2.17" + (defun collect-sub*directories-asd-files + (directory &key + (exclude asdf::*default-source-registry-exclusions*) + collect) + (asdf::collect-sub*directories + directory + (constantly t) + (lambda (x) (not (member (car (last (pathname-directory x))) + exclude :test #'equal))) + (lambda (dir) (collect-asds-in-directory dir collect)))) + + (defun system-source-directory (system-designator) + (asdf::pathname-directory-pathname + (asdf::system-source-file system-designator))) + + (defun filter-logical-directory-results (directory entries merger) + (if (typep directory 'logical-pathname) + (loop for f in entries + when + (if (typep f 'logical-pathname) + f + (let ((u (ignore-errors (funcall merger f)))) + (and u + (equal (ignore-errors (truename u)) + (truename f)) + u))) + collect it) + entries)) + + (defun directory-asd-files (directory) + (directory-files directory asdf::*wild-asd*))) + +(asdefs "2.19" + (defun subdirectories (directory) + (let* ((directory (asdf::ensure-directory-pathname directory)) + #-(or abcl cormanlisp xcl) + (wild (asdf::merge-pathnames* + #-(or abcl allegro cmu lispworks sbcl scl xcl) + asdf::*wild-directory* + #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*" + directory)) + (dirs + #-(or abcl cormanlisp xcl) + (ignore-errors + (directory* wild . #.(or #+clozure '(:directories t :files nil) + #+mcl '(:directories t)))) + #+(or abcl xcl) (system:list-directory directory) + #+cormanlisp (cl::directory-subdirs directory)) + #+(or abcl allegro cmu lispworks sbcl scl xcl) + (dirs (loop for x in dirs + for d = #+(or abcl xcl) (extensions:probe-directory x) + #+allegro (excl:probe-directory x) + #+(or cmu sbcl scl) (asdf::directory-pathname-p x) + #+lispworks (lw:file-directory-p x) + when d collect #+(or abcl allegro xcl) d + #+(or cmu lispworks sbcl scl) x))) + (filter-logical-directory-results + directory dirs + (let ((prefix (or (normalize-pathname-directory-component + (pathname-directory directory)) + ;; because allegro 8.x returns NIL for #p"FOO:" + '(:absolute)))) + (lambda (d) + (let ((dir (normalize-pathname-directory-component + (pathname-directory d)))) + (and (consp dir) (consp (cdr dir)) + (make-pathname + :defaults directory :name nil :type nil :version nil + :directory + (append prefix + (make-pathname-component-logical + (last dir)))))))))))) + +(asdefs "2.21" + (defun component-loaded-p (c) + (and (gethash 'load-op (asdf::component-operation-times + (asdf::find-component c nil))) t)) + + (defun normalize-pathname-directory-component (directory) + (cond + #-(or cmu sbcl scl) + ((stringp directory) `(:absolute ,directory) directory) + ((or (null directory) + (and (consp directory) + (member (first directory) '(:absolute :relative)))) + directory) + (t + (error "Unrecognized pathname directory component ~S" directory)))) + + (defun make-pathname-component-logical (x) + (typecase x + ((eql :unspecific) nil) + #+clisp (string (string-upcase x)) + #+clisp (cons (mapcar 'make-pathname-component-logical x)) + (t x))) + + (defun make-pathname-logical (pathname host) + (make-pathname + :host host + :directory (make-pathname-component-logical (pathname-directory pathname)) + :name (make-pathname-component-logical (pathname-name pathname)) + :type (make-pathname-component-logical (pathname-type pathname)) + :version (make-pathname-component-logical (pathname-version pathname))))) + +(asdefs "2.22" + (defun directory-files (directory &optional (pattern asdf::*wild-file*)) + (let ((dir (pathname directory))) + (when (typep dir 'logical-pathname) + (when (wild-pathname-p dir) + (error "Invalid wild pattern in logical directory ~S" directory)) + (unless (member (pathname-directory pattern) + '(() (:relative)) :test 'equal) + (error "Invalid file pattern ~S for logical directory ~S" + pattern directory)) + (setf pattern (make-pathname-logical pattern (pathname-host dir)))) + (let ((entries (ignore-errors + (directory* (asdf::merge-pathnames* pattern dir))))) + (filter-logical-directory-results + directory entries + (lambda (f) + (make-pathname :defaults dir + :name (make-pathname-component-logical + (pathname-name f)) + :type (make-pathname-component-logical + (pathname-type f)) + :version (make-pathname-component-logical + (pathname-version f))))))))) + +(asdefs "2.26.149" + (defmethod component-relative-pathname ((system asdf:system)) + (asdf::coerce-pathname + (and (slot-boundp system 'asdf::relative-pathname) + (slot-value system 'asdf::relative-pathname)) + :type :directory + :defaults (system-source-directory system))) + (defun load-asd (pathname &key name &allow-other-keys) + (asdf::load-sysdef (or name (string-downcase (pathname-name pathname))) + pathname))) + + +;;; Taken from ASDF 1.628 +(defmacro while-collecting ((&rest collectors) &body body) + `(asdf::while-collecting ,collectors ,@body)) + +;;; Now for SLIME-specific stuff + +(defun asdf-operation (operation) + (or (asdf::find-symbol* operation :asdf) + (error "Couldn't find ASDF operation ~S" operation))) + +(defun map-system-components (fn system) + (map-component-subcomponents fn (asdf:find-system system))) + +(defun map-component-subcomponents (fn component) + (when component + (funcall fn component) + (when (typep component 'asdf:module) + (dolist (c (asdf:module-components component)) + (map-component-subcomponents fn c))))) + +;;; Maintaining a pathname to component table + +(defvar *pathname-component* (make-hash-table :test 'equal)) + +(defun clear-pathname-component-table () + (clrhash *pathname-component*)) + +(defun register-system-pathnames (system) + (map-system-components 'register-component-pathname system)) + +(defun recompute-pathname-component-table () + (clear-pathname-component-table) + (asdf::map-systems 'register-system-pathnames)) + +(defun pathname-component (x) + (gethash (pathname x) *pathname-component*)) + +(defmethod asdf:component-pathname :around ((component asdf:component)) + (let ((p (call-next-method))) + (when (pathnamep p) + (setf (gethash p *pathname-component*) component)) + p)) + +(defun register-component-pathname (component) + (asdf:component-pathname component)) + +(recompute-pathname-component-table) + +;;; This is a crude hack, see ASDF's LP #481187. +(defslimefun who-depends-on (system) + (flet ((system-dependencies (op system) + (mapcar (lambda (dep) + (asdf::coerce-name (if (consp dep) (second dep) dep))) + (cdr (assoc op (asdf:component-depends-on op system)))))) + (let ((system-name (asdf::coerce-name system)) + (result)) + (asdf::map-systems + (lambda (system) + (when (member system-name + (system-dependencies 'asdf:load-op system) + :test #'string=) + (push (asdf:component-name system) result)))) + result))) + +(defmethod xref-doit ((type (eql :depends-on)) thing) + (when (typep thing '(or string symbol)) + (loop for dependency in (who-depends-on thing) + for asd-file = (asdf:system-definition-pathname dependency) + when asd-file + collect (list dependency + (swank/backend:make-location + `(:file ,(namestring asd-file)) + `(:position 1) + `(:snippet ,(format nil "(defsystem :~A" dependency) + :align t)))))) + +(defslimefun operate-on-system-for-emacs (system-name operation &rest keywords) + "Compile and load SYSTEM using ASDF. +Record compiler notes signalled as `compiler-condition's." + (collect-notes + (lambda () + (apply #'operate-on-system system-name operation keywords)))) + +(defun operate-on-system (system-name operation-name &rest keyword-args) + "Perform OPERATION-NAME on SYSTEM-NAME using ASDF. +The KEYWORD-ARGS are passed on to the operation. +Example: +\(operate-on-system \"cl-ppcre\" 'compile-op :force t)" + (handler-case + (with-compilation-hooks () + (apply #'asdf:operate (asdf-operation operation-name) + system-name keyword-args) + t) + ((or asdf:compile-error #+asdf3 asdf/lisp-build:compile-file-error) + () nil))) + +(defun unique-string-list (&rest lists) + (sort (delete-duplicates (apply #'append lists) :test #'string=) #'string<)) + +(defslimefun list-all-systems-in-central-registry () + "Returns a list of all systems in ASDF's central registry +AND in its source-registry. (legacy name)" + (unique-string-list + (mapcar + #'pathname-name + (while-collecting (c) + (loop for dir in asdf:*central-registry* + for defaults = (eval dir) + when defaults + do (collect-asds-in-directory defaults #'c)) + (asdf:ensure-source-registry) + (if (or #+asdf3 t + #-asdf3 (asdf:version-satisfies (asdf:asdf-version) "2.15")) + (loop :for k :being :the :hash-keys :of asdf::*source-registry* + :do (c k)) + #-asdf3 + (dolist (entry (asdf::flatten-source-registry)) + (destructuring-bind (directory &key recurse exclude) entry + (register-asd-directory + directory + :recurse recurse :exclude exclude :collect #'c)))))))) + +(defslimefun list-all-systems-known-to-asdf () + "Returns a list of all systems ASDF knows already." + (while-collecting (c) + (asdf::map-systems (lambda (system) (c (asdf:component-name system)))))) + +(defslimefun list-asdf-systems () + "Returns the systems in ASDF's central registry and those which ASDF +already knows." + (unique-string-list + (list-all-systems-known-to-asdf) + (list-all-systems-in-central-registry))) + +(defun asdf-component-source-files (component) + (while-collecting (c) + (labels ((f (x) + (typecase x + (asdf:source-file (c (asdf:component-pathname x))) + (asdf:module (map () #'f (asdf:module-components x)))))) + (f component)))) + +(defun asdf-component-output-files (component) + (while-collecting (c) + (labels ((f (x) + (typecase x + (asdf:source-file + (map () #'c + (asdf:output-files (make-instance 'asdf:compile-op) x))) + (asdf:module (map () #'f (asdf:module-components x)))))) + (f component)))) + +(defslimefun asdf-system-files (name) + (let* ((system (asdf:find-system name)) + (files (mapcar #'namestring + (cons + (asdf:system-definition-pathname system) + (asdf-component-source-files system)))) + (main-file (find name files + :test #'equalp :key #'pathname-name :start 1))) + (if main-file + (cons main-file (remove main-file files + :test #'equal :count 1)) + files))) + +(defslimefun asdf-system-loaded-p (name) + (component-loaded-p name)) + +(defslimefun asdf-system-directory (name) + (namestring (asdf:system-source-directory name))) + +(defun pathname-system (pathname) + (let ((component (pathname-component pathname))) + (when component + (asdf:component-name (asdf:component-system component))))) + +(defslimefun asdf-determine-system (file buffer-package-name) + (or + (and file + (pathname-system file)) + (and file + (progn + ;; If not found, let's rebuild the table first + (recompute-pathname-component-table) + (pathname-system file))) + ;; If we couldn't find an already defined system, + ;; try finding a system that's named like BUFFER-PACKAGE-NAME. + (loop with package = (guess-buffer-package buffer-package-name) + for name in (package-names package) + for system = (asdf:find-system (asdf::coerce-name name) nil) + when (and system + (or (not file) + (pathname-system file))) + return (asdf:component-name system)))) + +(defslimefun delete-system-fasls (name) + (let ((removed-count + (loop for file in (asdf-component-output-files + (asdf:find-system name)) + when (probe-file file) + count it + and + do (delete-file file)))) + (format nil "~d file~:p ~:*~[were~;was~:;were~] removed" removed-count))) + +(defvar *recompile-system* nil) + +(defmethod asdf:operation-done-p :around + ((operation asdf:compile-op) + component) + (unless (eql *recompile-system* + (asdf:component-system component)) + (call-next-method))) + +(defslimefun reload-system (name) + (let ((*recompile-system* (asdf:find-system name))) + (operate-on-system-for-emacs name 'asdf:load-op))) + +;; Doing list-all-systems-in-central-registry might be quite slow +;; since it accesses a file-system, so run it once at the background +;; to initialize caches. +(when (eql *communication-style* :spawn) + (spawn (lambda () + (ignore-errors (list-all-systems-in-central-registry))) + :name "init-asdf-fs-caches")) + +;;; Hook for compile-file-for-emacs + +(defun try-compile-file-with-asdf (pathname load-p &rest options) + (declare (ignore options)) + (let ((component (pathname-component pathname))) + (when component + ;;(format t "~&Compiling ASDF component ~S~%" component) + (let ((op (make-instance 'asdf:compile-op))) + (with-compilation-hooks () + (asdf:perform op component)) + (when load-p + (asdf:perform (make-instance 'asdf:load-op) component)) + (values t t nil (first (asdf:output-files op component))))))) + +(defun try-compile-asd-file (pathname load-p &rest options) + (declare (ignore load-p options)) + (when (equalp (pathname-type pathname) "asd") + (load-asd pathname) + (values t t nil pathname))) + +(pushnew 'try-compile-asd-file *compile-file-for-emacs-hook*) + +;;; (pushnew 'try-compile-file-with-asdf *compile-file-for-emacs-hook*) + +(provide :swank-asdf) diff --git a/vim/bundle/slimv/slime/contrib/swank-c-p-c.lisp b/vim/bundle/slimv/slime/contrib/swank-c-p-c.lisp new file mode 100644 index 0000000..6a766fb --- /dev/null +++ b/vim/bundle/slimv/slime/contrib/swank-c-p-c.lisp @@ -0,0 +1,298 @@ +;;; swank-c-p-c.lisp -- ILISP style Compound Prefix Completion +;; +;; Author: Luke Gorrie <luke@synap.se> +;; Edi Weitz <edi@agharta.de> +;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> +;; Tobias C. Rittweiler <tcr@freebits.de> +;; and others +;; +;; License: Public Domain +;; + + +(in-package :swank) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (swank-require :swank-util)) + +(defslimefun completions (string default-package-name) + "Return a list of completions for a symbol designator STRING. + +The result is the list (COMPLETION-SET COMPLETED-PREFIX), where +COMPLETION-SET is the list of all matching completions, and +COMPLETED-PREFIX is the best (partial) completion of the input +string. + +Simple compound matching is supported on a per-hyphen basis: + + (completions \"m-v-\" \"COMMON-LISP\") + ==> ((\"multiple-value-bind\" \"multiple-value-call\" + \"multiple-value-list\" \"multiple-value-prog1\" + \"multiple-value-setq\" \"multiple-values-limit\") + \"multiple-value\") + +\(For more advanced compound matching, see FUZZY-COMPLETIONS.) + +If STRING is package qualified the result list will also be +qualified. If string is non-qualified the result strings are +also not qualified and are considered relative to +DEFAULT-PACKAGE-NAME. + +The way symbols are matched depends on the symbol designator's +format. The cases are as follows: + FOO - Symbols with matching prefix and accessible in the buffer package. + PKG:FOO - Symbols with matching prefix and external in package PKG. + PKG::FOO - Symbols with matching prefix and accessible in package PKG. +" + (multiple-value-bind (name package-name package internal-p) + (parse-completion-arguments string default-package-name) + (let* ((symbol-set (symbol-completion-set + name package-name package internal-p + (make-compound-prefix-matcher #\-))) + (package-set (package-completion-set + name package-name package internal-p + (make-compound-prefix-matcher '(#\. #\-)))) + (completion-set + (format-completion-set (nconc symbol-set package-set) + internal-p package-name))) + (when completion-set + (list completion-set (longest-compound-prefix completion-set)))))) + + +;;;;; Find completion set + +(defun symbol-completion-set (name package-name package internal-p matchp) + "Return the set of completion-candidates as strings." + (mapcar (completion-output-symbol-converter name) + (and package + (mapcar #'symbol-name + (find-matching-symbols name + package + (and (not internal-p) + package-name) + matchp))))) + +(defun package-completion-set (name package-name package internal-p matchp) + (declare (ignore package internal-p)) + (mapcar (completion-output-package-converter name) + (and (not package-name) + (find-matching-packages name matchp)))) + +(defun find-matching-symbols (string package external test) + "Return a list of symbols in PACKAGE matching STRING. +TEST is called with two strings. If EXTERNAL is true, only external +symbols are returned." + (let ((completions '()) + (converter (completion-output-symbol-converter string))) + (flet ((symbol-matches-p (symbol) + (and (or (not external) + (symbol-external-p symbol package)) + (funcall test string + (funcall converter (symbol-name symbol)))))) + (do-symbols* (symbol package) + (when (symbol-matches-p symbol) + (push symbol completions)))) + completions)) + +(defun find-matching-symbols-in-list (string list test) + "Return a list of symbols in LIST matching STRING. +TEST is called with two strings." + (let ((completions '()) + (converter (completion-output-symbol-converter string))) + (flet ((symbol-matches-p (symbol) + (funcall test string + (funcall converter (symbol-name symbol))))) + (dolist (symbol list) + (when (symbol-matches-p symbol) + (push symbol completions)))) + (remove-duplicates completions))) + +(defun find-matching-packages (name matcher) + "Return a list of package names matching NAME with MATCHER. +MATCHER is a two-argument predicate." + (let ((converter (completion-output-package-converter name))) + (remove-if-not (lambda (x) + (funcall matcher name (funcall converter x))) + (mapcar (lambda (pkgname) + (concatenate 'string pkgname ":")) + (loop for package in (list-all-packages) + nconcing (package-names package)))))) + + +;; PARSE-COMPLETION-ARGUMENTS return table: +;; +;; user behaviour | NAME | PACKAGE-NAME | PACKAGE +;; ----------------+--------+--------------+----------------------------------- +;; asdf [tab] | "asdf" | NIL | #<PACKAGE "DEFAULT-PACKAGE-NAME"> +;; | | | or *BUFFER-PACKAGE* +;; asdf: [tab] | "" | "asdf" | #<PACKAGE "ASDF"> +;; | | | +;; asdf:foo [tab] | "foo" | "asdf" | #<PACKAGE "ASDF"> +;; | | | +;; as:fo [tab] | "fo" | "as" | NIL +;; | | | +;; : [tab] | "" | "" | #<PACKAGE "KEYWORD"> +;; | | | +;; :foo [tab] | "foo" | "" | #<PACKAGE "KEYWORD"> +;; +(defun parse-completion-arguments (string default-package-name) + "Parse STRING as a symbol designator. +Return these values: + SYMBOL-NAME + PACKAGE-NAME, or nil if the designator does not include an explicit package. + PACKAGE, generally the package to complete in. (However, if PACKAGE-NAME is + NIL, return the respective package of DEFAULT-PACKAGE-NAME instead; + if PACKAGE is non-NIL but a package cannot be found under that name, + return NIL.) + INTERNAL-P, if the symbol is qualified with `::'." + (multiple-value-bind (name package-name internal-p) + (tokenize-symbol string) + (flet ((default-package () + (or (guess-package default-package-name) *buffer-package*))) + (let ((package (cond + ((not package-name) + (default-package)) + ((equal package-name "") + (guess-package (symbol-name :keyword))) + ((find-locally-nicknamed-package + package-name (default-package))) + (t + (guess-package package-name))))) + (values name package-name package internal-p))))) + +(defun completion-output-case-converter (input &optional with-escaping-p) + "Return a function to convert strings for the completion output. +INPUT is used to guess the preferred case." + (ecase (readtable-case *readtable*) + (:upcase (cond ((or with-escaping-p + (and (plusp (length input)) + (not (some #'lower-case-p input)))) + #'identity) + (t #'string-downcase))) + (:invert (lambda (output) + (multiple-value-bind (lower upper) (determine-case output) + (cond ((and lower upper) output) + (lower (string-upcase output)) + (upper (string-downcase output)) + (t output))))) + (:downcase (cond ((or with-escaping-p + (and (zerop (length input)) + (not (some #'upper-case-p input)))) + #'identity) + (t #'string-upcase))) + (:preserve #'identity))) + +(defun completion-output-package-converter (input) + "Return a function to convert strings for the completion output. +INPUT is used to guess the preferred case." + (completion-output-case-converter input)) + +(defun completion-output-symbol-converter (input) + "Return a function to convert strings for the completion output. +INPUT is used to guess the preferred case. Escape symbols when needed." + (let ((case-converter (completion-output-case-converter input)) + (case-converter-with-escaping (completion-output-case-converter input t))) + (lambda (str) + (if (or (multiple-value-bind (lowercase uppercase) + (determine-case str) + ;; In these readtable cases, symbols with letters from + ;; the wrong case need escaping + (case (readtable-case *readtable*) + (:upcase lowercase) + (:downcase uppercase) + (t nil))) + (some (lambda (el) + (or (member el '(#\: #\Space #\Newline #\Tab)) + (multiple-value-bind (macrofun nonterminating) + (get-macro-character el) + (and macrofun + (not nonterminating))))) + str)) + (concatenate 'string "|" (funcall case-converter-with-escaping str) "|") + (funcall case-converter str))))) + + +(defun determine-case (string) + "Return two booleans LOWER and UPPER indicating whether STRING +contains lower or upper case characters." + (values (some #'lower-case-p string) + (some #'upper-case-p string))) + + +;;;;; Compound-prefix matching + +(defun make-compound-prefix-matcher (delimiter &key (test #'char=)) + "Returns a matching function that takes a `prefix' and a +`target' string and which returns T if `prefix' is a +compound-prefix of `target', and otherwise NIL. + +Viewing each of `prefix' and `target' as a series of substrings +delimited by DELIMITER, if each substring of `prefix' is a prefix +of the corresponding substring in `target' then we call `prefix' +a compound-prefix of `target'. + +DELIMITER may be a character, or a list of characters." + (let ((delimiters (etypecase delimiter + (character (list delimiter)) + (cons (assert (every #'characterp delimiter)) + delimiter)))) + (lambda (prefix target) + (declare (type simple-string prefix target)) + (loop with tpos = 0 + for ch across prefix + always (and (< tpos (length target)) + (let ((delimiter (car (member ch delimiters :test test)))) + (if delimiter + (setf tpos (position delimiter target :start tpos)) + (funcall test ch (aref target tpos))))) + do (incf tpos))))) + + +;;;;; Extending the input string by completion + +(defun longest-compound-prefix (completions &optional (delimiter #\-)) + "Return the longest compound _prefix_ for all COMPLETIONS." + (flet ((tokenizer (string) (tokenize-completion string delimiter))) + (untokenize-completion + (loop for token-list in (transpose-lists (mapcar #'tokenizer completions)) + if (notevery #'string= token-list (rest token-list)) + ;; Note that we possibly collect the "" here as well, so that + ;; UNTOKENIZE-COMPLETION will append a delimiter for us. + collect (longest-common-prefix token-list) + and do (loop-finish) + else collect (first token-list)) + delimiter))) + +(defun tokenize-completion (string delimiter) + "Return all substrings of STRING delimited by DELIMITER." + (loop with end + for start = 0 then (1+ end) + until (> start (length string)) + do (setq end (or (position delimiter string :start start) (length string))) + collect (subseq string start end))) + +(defun untokenize-completion (tokens &optional (delimiter #\-)) + (format nil (format nil "~~{~~A~~^~a~~}" delimiter) tokens)) + +(defun transpose-lists (lists) + "Turn a list-of-lists on its side. +If the rows are of unequal length, truncate uniformly to the shortest. + +For example: +\(transpose-lists '((ONE TWO THREE) (1 2))) + => ((ONE 1) (TWO 2))" + (cond ((null lists) '()) + ((some #'null lists) '()) + (t (cons (mapcar #'car lists) + (transpose-lists (mapcar #'cdr lists)))))) + + +;;;; Completion for character names + +(defslimefun completions-for-character (prefix) + (let* ((matcher (make-compound-prefix-matcher #\_ :test #'char-equal)) + (completion-set (character-completion-set prefix matcher)) + (completions (sort completion-set #'string<))) + (list completions (longest-compound-prefix completions #\_)))) + +(provide :swank-c-p-c) diff --git a/vim/bundle/slimv/slime/contrib/swank-clipboard.lisp b/vim/bundle/slimv/slime/contrib/swank-clipboard.lisp new file mode 100644 index 0000000..52b1085 --- /dev/null +++ b/vim/bundle/slimv/slime/contrib/swank-clipboard.lisp @@ -0,0 +1,71 @@ +;;; swank-clipboard.lisp --- Object clipboard +;; +;; Written by Helmut Eller in 2008. +;; License: Public Domain + +(defpackage :swank-clipboard + (:use :cl) + (:import-from :swank :defslimefun :with-buffer-syntax :dcase) + (:export :add :delete-entry :entries :entry-to-ref :ref)) + +(in-package :swank-clipboard) + +(defstruct clipboard entries (counter 0)) + +(defvar *clipboard* (make-clipboard)) + +(defslimefun add (datum) + (let ((value (dcase datum + ((:string string package) + (with-buffer-syntax (package) + (eval (read-from-string string)))) + ((:inspector part) + (swank:inspector-nth-part part)) + ((:sldb frame var) + (swank/backend:frame-var-value frame var))))) + (clipboard-add value) + (format nil "Added: ~a" + (entry-to-string (1- (length (clipboard-entries *clipboard*))))))) + +(defslimefun entries () + (loop for (ref . value) in (clipboard-entries *clipboard*) + collect `(,ref . ,(to-line value)))) + +(defslimefun delete-entry (entry) + (let ((msg (format nil "Deleted: ~a" (entry-to-string entry)))) + (clipboard-delete-entry entry) + msg)) + +(defslimefun entry-to-ref (entry) + (destructuring-bind (ref . value) (clipboard-entry entry) + (list ref (to-line value 5)))) + +(defun clipboard-add (value) + (setf (clipboard-entries *clipboard*) + (append (clipboard-entries *clipboard*) + (list (cons (incf (clipboard-counter *clipboard*)) + value))))) + +(defun clipboard-ref (ref) + (let ((tail (member ref (clipboard-entries *clipboard*) :key #'car))) + (cond (tail (cdr (car tail))) + (t (error "Invalid clipboard ref: ~s" ref))))) + +(defun clipboard-entry (entry) + (elt (clipboard-entries *clipboard*) entry)) + +(defun clipboard-delete-entry (index) + (let* ((list (clipboard-entries *clipboard*)) + (tail (nthcdr index list))) + (setf (clipboard-entries *clipboard*) + (append (ldiff list tail) (cdr tail))))) + +(defun entry-to-string (entry) + (destructuring-bind (ref . value) (clipboard-entry entry) + (format nil "#@~d(~a)" ref (to-line value)))) + +(defun to-line (object &optional (width 75)) + (with-output-to-string (*standard-output*) + (write object :right-margin width :lines 1))) + +(provide :swank-clipboard) diff --git a/vim/bundle/slimv/slime/contrib/swank-fancy-inspector.lisp b/vim/bundle/slimv/slime/contrib/swank-fancy-inspector.lisp new file mode 100644 index 0000000..3e46df9 --- /dev/null +++ b/vim/bundle/slimv/slime/contrib/swank-fancy-inspector.lisp @@ -0,0 +1,1004 @@ +;;; swank-fancy-inspector.lisp --- Fancy inspector for CLOS objects +;; +;; Author: Marco Baringer <mb@bese.it> and others +;; License: Public Domain +;; + +(in-package :swank) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (swank-require :swank-util)) + +(defmethod emacs-inspect ((symbol symbol)) + (let ((package (symbol-package symbol))) + (multiple-value-bind (_symbol status) + (and package (find-symbol (string symbol) package)) + (declare (ignore _symbol)) + (append + (label-value-line "Its name is" (symbol-name symbol)) + ;; + ;; Value + (cond ((boundp symbol) + (append + (label-value-line (if (constantp symbol) + "It is a constant of value" + "It is a global variable bound to") + (symbol-value symbol) :newline nil) + ;; unbinding constants might be not a good idea, but + ;; implementations usually provide a restart. + `(" " (:action "[unbind]" + ,(lambda () (makunbound symbol)))) + '((:newline)))) + (t '("It is unbound." (:newline)))) + (docstring-ispec "Documentation" symbol 'variable) + (multiple-value-bind (expansion definedp) (macroexpand symbol) + (if definedp + (label-value-line "It is a symbol macro with expansion" + expansion))) + ;; + ;; Function + (if (fboundp symbol) + (append (if (macro-function symbol) + `("It a macro with macro-function: " + (:value ,(macro-function symbol))) + `("It is a function: " + (:value ,(symbol-function symbol)))) + `(" " (:action "[unbind]" + ,(lambda () (fmakunbound symbol)))) + `((:newline))) + `("It has no function value." (:newline))) + (docstring-ispec "Function documentation" symbol 'function) + (when (compiler-macro-function symbol) + (append + (label-value-line "It also names the compiler macro" + (compiler-macro-function symbol) :newline nil) + `(" " (:action "[remove]" + ,(lambda () + (setf (compiler-macro-function symbol) nil))) + (:newline)))) + (docstring-ispec "Compiler macro documentation" + symbol 'compiler-macro) + ;; + ;; Package + (if package + `("It is " ,(string-downcase (string status)) + " to the package: " + (:value ,package ,(package-name package)) + ,@(if (eq :internal status) + `(" " + (:action "[export]" + ,(lambda () (export symbol package))))) + " " + (:action "[unintern]" + ,(lambda () (unintern symbol package))) + (:newline)) + '("It is a non-interned symbol." (:newline))) + ;; + ;; Plist + (label-value-line "Property list" (symbol-plist symbol)) + ;; + ;; Class + (if (find-class symbol nil) + `("It names the class " + (:value ,(find-class symbol) ,(string symbol)) + " " + (:action "[remove]" + ,(lambda () (setf (find-class symbol) nil))) + (:newline))) + ;; + ;; More package + (if (find-package symbol) + (label-value-line "It names the package" (find-package symbol))) + (inspect-type-specifier symbol))))) + +#-sbcl +(defun inspect-type-specifier (symbol) + (declare (ignore symbol))) + +#+sbcl +(defun inspect-type-specifier (symbol) + (let* ((kind (sb-int:info :type :kind symbol)) + (fun (case kind + (:defined + (or (sb-int:info :type :expander symbol) t)) + (:primitive + (or #.(if (swank/sbcl::sbcl-version>= 1 3 1) + '(let ((x (sb-int:info :type :expander symbol))) + (if (consp x) + (car x) + x)) + '(sb-int:info :type :translator symbol)) + t))))) + (when fun + (append + (list + (format nil "It names a ~@[primitive~* ~]type-specifier." + (eq kind :primitive)) + '(:newline)) + (docstring-ispec "Type-specifier documentation" symbol 'type) + (unless (eq t fun) + (let ((arglist (arglist fun))) + (append + `("Type-specifier lambda-list: " + ;; Could use ~:s, but inspector-princ does a bit more, + ;; and not all NILs in the arglist should be printed that way. + ,(if arglist + (inspector-princ arglist) + "()") + (:newline)) + (multiple-value-bind (expansion ok) + (handler-case (sb-ext:typexpand-1 symbol) + (error () (values nil nil))) + (when ok + (list "Type-specifier expansion: " + (princ-to-string expansion))))))))))) + +(defun docstring-ispec (label object kind) + "Return a inspector spec if OBJECT has a docstring of kind KIND." + (let ((docstring (documentation object kind))) + (cond ((not docstring) nil) + ((< (+ (length label) (length docstring)) + 75) + (list label ": " docstring '(:newline))) + (t + (list label ":" '(:newline) " " docstring '(:newline)))))) + +(unless (find-method #'emacs-inspect '() (list (find-class 'function)) nil) + (defmethod emacs-inspect ((f function)) + (inspect-function f))) + +(defun inspect-function (f) + (append + (label-value-line "Name" (function-name f)) + `("Its argument list is: " + ,(inspector-princ (arglist f)) (:newline)) + (docstring-ispec "Documentation" f t) + (if (function-lambda-expression f) + (label-value-line "Lambda Expression" + (function-lambda-expression f))))) + +(defun method-specializers-for-inspect (method) + "Return a \"pretty\" list of the method's specializers. Normal + specializers are replaced by the name of the class, eql + specializers are replaced by `(eql ,object)." + (mapcar (lambda (spec) + (typecase spec + (swank-mop:eql-specializer + `(eql ,(swank-mop:eql-specializer-object spec))) + #-sbcl + (t + (swank-mop:class-name spec)) + #+sbcl + (t + ;; SBCL has extended specializers + (let ((gf (sb-mop:method-generic-function method))) + (cond (gf + (sb-pcl:unparse-specializer-using-class gf spec)) + ((typep spec 'class) + (class-name spec)) + (t + spec)))))) + (swank-mop:method-specializers method))) + +(defun method-for-inspect-value (method) + "Returns a \"pretty\" list describing METHOD. The first element + of the list is the name of generic-function method is + specialiazed on, the second element is the method qualifiers, + the rest of the list is the method's specialiazers (as per + method-specializers-for-inspect)." + (append (list (swank-mop:generic-function-name + (swank-mop:method-generic-function method))) + (swank-mop:method-qualifiers method) + (method-specializers-for-inspect method))) + +(defmethod emacs-inspect ((object standard-object)) + (let ((class (class-of object))) + `("Class: " (:value ,class) (:newline) + ,@(all-slots-for-inspector object)))) + +(defvar *gf-method-getter* 'methods-by-applicability + "This function is called to get the methods of a generic function. +The default returns the method sorted by applicability. +See `methods-by-applicability'.") + +(defun specializer< (specializer1 specializer2) + "Return true if SPECIALIZER1 is more specific than SPECIALIZER2." + (let ((s1 specializer1) (s2 specializer2) ) + (cond ((typep s1 'swank-mop:eql-specializer) + (not (typep s2 'swank-mop:eql-specializer))) + ((typep s1 'class) + (flet ((cpl (class) + (and (swank-mop:class-finalized-p class) + (swank-mop:class-precedence-list class)))) + (member s2 (cpl s1))))))) + +(defun methods-by-applicability (gf) + "Return methods ordered by most specific argument types. + +`method-specializer<' is used for sorting." + ;; FIXME: argument-precedence-order and qualifiers are ignored. + (labels ((method< (meth1 meth2) + (loop for s1 in (swank-mop:method-specializers meth1) + for s2 in (swank-mop:method-specializers meth2) + do (cond ((specializer< s2 s1) (return nil)) + ((specializer< s1 s2) (return t)))))) + (stable-sort (copy-seq (swank-mop:generic-function-methods gf)) + #'method<))) + +(defun abbrev-doc (doc &optional (maxlen 80)) + "Return the first sentence of DOC, but not more than MAXLAN characters." + (subseq doc 0 (min (1+ (or (position #\. doc) (1- maxlen))) + maxlen + (length doc)))) + +(defstruct (inspector-checklist (:conc-name checklist.) + (:constructor %make-checklist (buttons))) + (buttons nil :type (or null simple-vector)) + (count 0)) + +(defun make-checklist (n) + (%make-checklist (make-array n :initial-element nil))) + +(defun reinitialize-checklist (checklist) + ;; Along this counter the buttons are created, so we have to + ;; initialize it to 0 everytime the inspector page is redisplayed. + (setf (checklist.count checklist) 0) + checklist) + +(defun make-checklist-button (checklist) + (let ((buttons (checklist.buttons checklist)) + (i (checklist.count checklist))) + (incf (checklist.count checklist)) + `(:action ,(if (svref buttons i) + "[X]" + "[ ]") + ,#'(lambda () + (setf (svref buttons i) (not (svref buttons i)))) + :refreshp t))) + +(defmacro do-checklist ((idx checklist) &body body) + "Iterate over all set buttons in CHECKLIST." + (let ((buttons (gensym "buttons"))) + `(let ((,buttons (checklist.buttons ,checklist))) + (dotimes (,idx (length ,buttons)) + (when (svref ,buttons ,idx) + ,@body))))) + +(defun box (thing) (cons :box thing)) +(defun ref (box) + (assert (eq (car box) :box)) + (cdr box)) +(defun (setf ref) (value box) + (assert (eq (car box) :box)) + (setf (cdr box) value)) + +(defvar *inspector-slots-default-order* :alphabetically + "Accepted values: :alphabetically and :unsorted") + +(defvar *inspector-slots-default-grouping* :all + "Accepted values: :inheritance and :all") + +(defgeneric all-slots-for-inspector (object)) + +(defmethod all-slots-for-inspector ((object standard-object)) + (let* ((class (class-of object)) + (direct-slots (swank-mop:class-direct-slots class)) + (effective-slots (swank-mop:class-slots class)) + (longest-slot-name-length + (loop for slot :in effective-slots + maximize (length (symbol-name + (swank-mop:slot-definition-name slot))))) + (checklist + (reinitialize-checklist + (ensure-istate-metadata object :checklist + (make-checklist (length effective-slots))))) + (grouping-kind + ;; We box the value so we can re-set it. + (ensure-istate-metadata object :grouping-kind + (box *inspector-slots-default-grouping*))) + (sort-order + (ensure-istate-metadata object :sort-order + (box *inspector-slots-default-order*))) + (sort-predicate (ecase (ref sort-order) + (:alphabetically #'string<) + (:unsorted (constantly nil)))) + (sorted-slots (sort (copy-seq effective-slots) + sort-predicate + :key #'swank-mop:slot-definition-name)) + (effective-slots + (ecase (ref grouping-kind) + (:all sorted-slots) + (:inheritance (stable-sort-by-inheritance sorted-slots + class sort-predicate))))) + `("--------------------" + (:newline) + " Group slots by inheritance " + (:action ,(ecase (ref grouping-kind) + (:all "[ ]") + (:inheritance "[X]")) + ,(lambda () + ;; We have to do this as the order of slots will + ;; be sorted differently. + (fill (checklist.buttons checklist) nil) + (setf (ref grouping-kind) + (ecase (ref grouping-kind) + (:all :inheritance) + (:inheritance :all)))) + :refreshp t) + (:newline) + " Sort slots alphabetically " + (:action ,(ecase (ref sort-order) + (:unsorted "[ ]") + (:alphabetically "[X]")) + ,(lambda () + (fill (checklist.buttons checklist) nil) + (setf (ref sort-order) + (ecase (ref sort-order) + (:unsorted :alphabetically) + (:alphabetically :unsorted)))) + :refreshp t) + (:newline) + ,@ (case (ref grouping-kind) + (:all + `((:newline) + "All Slots:" + (:newline) + ,@(make-slot-listing checklist object class + effective-slots direct-slots + longest-slot-name-length))) + (:inheritance + (list-all-slots-by-inheritance checklist object class + effective-slots direct-slots + longest-slot-name-length))) + (:newline) + (:action "[set value]" + ,(lambda () + (do-checklist (idx checklist) + (query-and-set-slot class object + (nth idx effective-slots)))) + :refreshp t) + " " + (:action "[make unbound]" + ,(lambda () + (do-checklist (idx checklist) + (swank-mop:slot-makunbound-using-class + class object (nth idx effective-slots)))) + :refreshp t) + (:newline)))) + +(defun list-all-slots-by-inheritance (checklist object class effective-slots + direct-slots longest-slot-name-length) + (flet ((slot-home-class (slot) + (slot-home-class-using-class slot class))) + (let ((current-slots '())) + (append + (loop for slot in effective-slots + for previous-home-class = (slot-home-class slot) then home-class + for home-class = previous-home-class then (slot-home-class slot) + if (eq home-class previous-home-class) + do (push slot current-slots) + else + collect '(:newline) + and collect (format nil "~A:" (class-name previous-home-class)) + and collect '(:newline) + and append (make-slot-listing checklist object class + (nreverse current-slots) + direct-slots + longest-slot-name-length) + and do (setf current-slots (list slot))) + (and current-slots + `((:newline) + ,(format nil "~A:" + (class-name (slot-home-class-using-class + (car current-slots) class))) + (:newline) + ,@(make-slot-listing checklist object class + (nreverse current-slots) direct-slots + longest-slot-name-length))))))) + +(defun make-slot-listing (checklist object class effective-slots direct-slots + longest-slot-name-length) + (flet ((padding-for (slot-name) + (make-string (- longest-slot-name-length (length slot-name)) + :initial-element #\Space))) + (loop + for effective-slot :in effective-slots + for direct-slot = (find (swank-mop:slot-definition-name effective-slot) + direct-slots + :key #'swank-mop:slot-definition-name) + for slot-name = (inspector-princ + (swank-mop:slot-definition-name effective-slot)) + collect (make-checklist-button checklist) + collect " " + collect `(:value ,(if direct-slot + (list direct-slot effective-slot) + effective-slot) + ,slot-name) + collect (padding-for slot-name) + collect " = " + collect (slot-value-for-inspector class object effective-slot) + collect '(:newline)))) + +(defgeneric slot-value-for-inspector (class object slot) + (:method (class object slot) + (let ((boundp (swank-mop:slot-boundp-using-class class object slot))) + (if boundp + `(:value ,(swank-mop:slot-value-using-class class object slot)) + "#<unbound>")))) + +(defun slot-home-class-using-class (slot class) + (let ((slot-name (swank-mop:slot-definition-name slot))) + (loop for class in (reverse (swank-mop:class-precedence-list class)) + thereis (and (member slot-name (swank-mop:class-direct-slots class) + :key #'swank-mop:slot-definition-name + :test #'eq) + class)))) + +(defun stable-sort-by-inheritance (slots class predicate) + (stable-sort slots predicate + :key #'(lambda (s) + (class-name (slot-home-class-using-class s class))))) + +(defun query-and-set-slot (class object slot) + (let* ((slot-name (swank-mop:slot-definition-name slot)) + (value-string (read-from-minibuffer-in-emacs + (format nil "Set slot ~S to (evaluated) : " + slot-name)))) + (when (and value-string (not (string= value-string ""))) + (with-simple-restart (abort "Abort setting slot ~S" slot-name) + (setf (swank-mop:slot-value-using-class class object slot) + (eval (read-from-string value-string))))))) + + +(defmethod emacs-inspect ((gf standard-generic-function)) + (flet ((lv (label value) (label-value-line label value))) + (append + (lv "Name" (swank-mop:generic-function-name gf)) + (lv "Arguments" (swank-mop:generic-function-lambda-list gf)) + (docstring-ispec "Documentation" gf t) + (lv "Method class" (swank-mop:generic-function-method-class gf)) + (lv "Method combination" + (swank-mop:generic-function-method-combination gf)) + `("Methods: " (:newline)) + (loop for method in (funcall *gf-method-getter* gf) append + `((:value ,method ,(inspector-princ + ;; drop the name of the GF + (cdr (method-for-inspect-value method)))) + " " + (:action "[remove method]" + ,(let ((m method)) ; LOOP reassigns method + (lambda () + (remove-method gf m)))) + (:newline))) + `((:newline)) + (all-slots-for-inspector gf)))) + +(defmethod emacs-inspect ((method standard-method)) + `(,@(if (swank-mop:method-generic-function method) + `("Method defined on the generic function " + (:value ,(swank-mop:method-generic-function method) + ,(inspector-princ + (swank-mop:generic-function-name + (swank-mop:method-generic-function method))))) + '("Method without a generic function")) + (:newline) + ,@(docstring-ispec "Documentation" method t) + "Lambda List: " (:value ,(swank-mop:method-lambda-list method)) + (:newline) + "Specializers: " (:value ,(swank-mop:method-specializers method) + ,(inspector-princ + (method-specializers-for-inspect method))) + (:newline) + "Qualifiers: " (:value ,(swank-mop:method-qualifiers method)) + (:newline) + "Method function: " (:value ,(swank-mop:method-function method)) + (:newline) + ,@(all-slots-for-inspector method))) + +(defun specializer-direct-methods (class) + (sort (copy-seq (swank-mop:specializer-direct-methods class)) + #'string< + :key + (lambda (x) + (symbol-name + (let ((name (swank-mop::generic-function-name + (swank-mop::method-generic-function x)))) + (if (symbolp name) + name + (second name))))))) + +(defmethod emacs-inspect ((class standard-class)) + `("Name: " + (:value ,(class-name class)) + (:newline) + "Super classes: " + ,@(common-seperated-spec (swank-mop:class-direct-superclasses class)) + (:newline) + "Direct Slots: " + ,@(common-seperated-spec + (swank-mop:class-direct-slots class) + (lambda (slot) + `(:value ,slot ,(inspector-princ + (swank-mop:slot-definition-name slot))))) + (:newline) + "Effective Slots: " + ,@(if (swank-mop:class-finalized-p class) + (common-seperated-spec + (swank-mop:class-slots class) + (lambda (slot) + `(:value ,slot ,(inspector-princ + (swank-mop:slot-definition-name slot))))) + `("#<N/A (class not finalized)> " + (:action "[finalize]" + ,(lambda () (swank-mop:finalize-inheritance class))))) + (:newline) + ,@(let ((doc (documentation class t))) + (when doc + `("Documentation:" (:newline) ,(inspector-princ doc) (:newline)))) + "Sub classes: " + ,@(common-seperated-spec (swank-mop:class-direct-subclasses class) + (lambda (sub) + `(:value ,sub + ,(inspector-princ (class-name sub))))) + (:newline) + "Precedence List: " + ,@(if (swank-mop:class-finalized-p class) + (common-seperated-spec + (swank-mop:class-precedence-list class) + (lambda (class) + `(:value ,class ,(inspector-princ (class-name class))))) + '("#<N/A (class not finalized)>")) + (:newline) + ,@(when (swank-mop:specializer-direct-methods class) + `("It is used as a direct specializer in the following methods:" + (:newline) + ,@(loop + for method in (specializer-direct-methods class) + collect " " + collect `(:value ,method + ,(inspector-princ + (method-for-inspect-value method))) + collect '(:newline) + if (documentation method t) + collect " Documentation: " and + collect (abbrev-doc (documentation method t)) and + collect '(:newline)))) + "Prototype: " ,(if (swank-mop:class-finalized-p class) + `(:value ,(swank-mop:class-prototype class)) + '"#<N/A (class not finalized)>") + (:newline) + ,@(all-slots-for-inspector class))) + +(defmethod emacs-inspect ((slot swank-mop:standard-slot-definition)) + `("Name: " + (:value ,(swank-mop:slot-definition-name slot)) + (:newline) + ,@(when (swank-mop:slot-definition-documentation slot) + `("Documentation:" (:newline) + (:value ,(swank-mop:slot-definition-documentation + slot)) + (:newline))) + "Init args: " + (:value ,(swank-mop:slot-definition-initargs slot)) + (:newline) + "Init form: " + ,(if (swank-mop:slot-definition-initfunction slot) + `(:value ,(swank-mop:slot-definition-initform slot)) + "#<unspecified>") + (:newline) + "Init function: " + (:value ,(swank-mop:slot-definition-initfunction slot)) + (:newline) + ,@(all-slots-for-inspector slot))) + + +;; Wrapper structure over the list of symbols of a package that should +;; be displayed with their respective classification flags. This is +;; because we need a unique type to dispatch on in EMACS-INSPECT. +;; Used by the Inspector for packages. +(defstruct (%package-symbols-container + (:conc-name %container.) + (:constructor %%make-package-symbols-container)) + title ;; A string; the title of the inspector page in Emacs. + description ;; A list of renderable objects; used as description. + symbols ;; A list of symbols. Supposed to be sorted alphabetically. + grouping-kind) ;; Either :SYMBOL or :CLASSIFICATION. Cf. MAKE-SYMBOLS-LISTING + + +(defun %make-package-symbols-container (&key title description symbols) + (%%make-package-symbols-container :title title :description description + :symbols symbols :grouping-kind :symbol)) + +(defgeneric make-symbols-listing (grouping-kind symbols)) + +(defmethod make-symbols-listing ((grouping-kind (eql :symbol)) symbols) + "Returns an object renderable by Emacs' inspector side that +alphabetically lists all the symbols in SYMBOLS together with a +concise string representation of what each symbol +represents (see SYMBOL-CLASSIFICATION-STRING)" + (let ((max-length (loop for s in symbols + maximizing (length (symbol-name s)))) + (distance 10)) ; empty distance between name and classification + (flet ((string-representations (symbol) + (let* ((name (symbol-name symbol)) + (length (length name)) + (padding (- max-length length))) + (values + (concatenate 'string + name + (make-string (+ padding distance) + :initial-element #\Space)) + (symbol-classification-string symbol))))) + `("" ; 8 is (length "Symbols:") + "Symbols:" ,(make-string (+ -8 max-length distance) + :initial-element #\Space) + "Flags:" + (:newline) + ,(concatenate 'string ; underlining dashes + (make-string (+ max-length distance -1) + :initial-element #\-) + " " + (symbol-classification-string '#:foo)) + (:newline) + ,@(loop for symbol in symbols appending + (multiple-value-bind (symbol-string classification-string) + (string-representations symbol) + `((:value ,symbol ,symbol-string) ,classification-string + (:newline) + ))))))) + +(defmethod make-symbols-listing ((grouping-kind (eql :classification)) symbols) + "For each possible classification (cf. CLASSIFY-SYMBOL), group +all the symbols in SYMBOLS to all of their respective +classifications. (If a symbol is, for instance, boundp and a +generic-function, it'll appear both below the BOUNDP group and +the GENERIC-FUNCTION group.) As macros and special-operators are +specified to be FBOUNDP, there is no general FBOUNDP group, +instead there are the three explicit FUNCTION, MACRO and +SPECIAL-OPERATOR groups." + (let ((table (make-hash-table :test #'eq)) + (+default-classification+ :misc)) + (flet ((normalize-classifications (classifications) + (cond ((null classifications) `(,+default-classification+)) + ;; Convert an :FBOUNDP in CLASSIFICATIONS to + ;; :FUNCTION if possible. + ((and (member :fboundp classifications) + (not (member :macro classifications)) + (not (member :special-operator classifications))) + (substitute :function :fboundp classifications)) + (t (remove :fboundp classifications))))) + (loop for symbol in symbols do + (loop for classification in + (normalize-classifications (classify-symbol symbol)) + ;; SYMBOLS are supposed to be sorted alphabetically; + ;; this property is preserved here except for reversing. + do (push symbol (gethash classification table))))) + (let* ((classifications (loop for k being each hash-key in table + collect k)) + (classifications (sort classifications + ;; Sort alphabetically, except + ;; +DEFAULT-CLASSIFICATION+ which + ;; sort to the end. + (lambda (a b) + (cond ((eql a +default-classification+) + nil) + ((eql b +default-classification+) + t) + (t (string< a b))))))) + (loop for classification in classifications + for symbols = (gethash classification table) + appending`(,(symbol-name classification) + (:newline) + ,(make-string 64 :initial-element #\-) + (:newline) + ,@(mapcan (lambda (symbol) + `((:value ,symbol ,(symbol-name symbol)) + (:newline))) + ;; restore alphabetic order. + (nreverse symbols)) + (:newline)))))) + +(defmethod emacs-inspect ((%container %package-symbols-container)) + (with-struct (%container. title description symbols grouping-kind) %container + `(,title (:newline) (:newline) + ,@description + (:newline) + " " ,(ecase grouping-kind + (:symbol + `(:action "[Group by classification]" + ,(lambda () + (setf grouping-kind :classification)) + :refreshp t)) + (:classification + `(:action "[Group by symbol]" + ,(lambda () (setf grouping-kind :symbol)) + :refreshp t))) + (:newline) (:newline) + ,@(make-symbols-listing grouping-kind symbols)))) + +(defun display-link (type symbols length &key title description) + (if (null symbols) + (format nil "0 ~A symbols." type) + `(:value ,(%make-package-symbols-container :title title + :description description + :symbols symbols) + ,(format nil "~D ~A symbol~P." length type length)))) + +(defmethod emacs-inspect ((package package)) + (let ((package-name (package-name package)) + (package-nicknames (package-nicknames package)) + (package-use-list (package-use-list package)) + (package-used-by-list (package-used-by-list package)) + (shadowed-symbols (package-shadowing-symbols package)) + (present-symbols '()) (present-symbols-length 0) + (internal-symbols '()) (internal-symbols-length 0) + (inherited-symbols '()) (inherited-symbols-length 0) + (external-symbols '()) (external-symbols-length 0)) + + (do-symbols* (sym package) + (let ((status (symbol-status sym package))) + (when (eq status :inherited) + (push sym inherited-symbols) (incf inherited-symbols-length) + (go :continue)) + (push sym present-symbols) (incf present-symbols-length) + (cond ((eq status :internal) + (push sym internal-symbols) (incf internal-symbols-length)) + (t + (push sym external-symbols) (incf external-symbols-length)))) + :continue) + + (setf package-nicknames (sort (copy-list package-nicknames) + #'string<) + package-use-list (sort (copy-list package-use-list) + #'string< :key #'package-name) + package-used-by-list (sort (copy-list package-used-by-list) + #'string< :key #'package-name) + shadowed-symbols (sort (copy-list shadowed-symbols) + #'string<)) + ;;; SORT + STRING-LESSP conses on at least SBCL 0.9.18. + (setf present-symbols (sort present-symbols #'string<) + internal-symbols (sort internal-symbols #'string<) + external-symbols (sort external-symbols #'string<) + inherited-symbols (sort inherited-symbols #'string<)) + `("" ;; dummy to preserve indentation. + "Name: " (:value ,package-name) (:newline) + + "Nick names: " ,@(common-seperated-spec package-nicknames) (:newline) + + ,@(when (documentation package t) + `("Documentation:" (:newline) + ,(documentation package t) (:newline))) + + "Use list: " ,@(common-seperated-spec + package-use-list + (lambda (package) + `(:value ,package ,(package-name package)))) + (:newline) + + "Used by list: " ,@(common-seperated-spec + package-used-by-list + (lambda (package) + `(:value ,package ,(package-name package)))) + (:newline) + + ,(display-link "present" present-symbols present-symbols-length + :title + (format nil "All present symbols of package \"~A\"" + package-name) + :description + '("A symbol is considered present in a package if it's" + (:newline) + "\"accessible in that package directly, rather than" + (:newline) + "being inherited from another package.\"" + (:newline) + "(CLHS glossary entry for `present')" + (:newline))) + + (:newline) + ,(display-link "external" external-symbols external-symbols-length + :title + (format nil "All external symbols of package \"~A\"" + package-name) + :description + '("A symbol is considered external of a package if it's" + (:newline) + "\"part of the `external interface' to the package and" + (:newline) + "[is] inherited by any other package that uses the" + (:newline) + "package.\" (CLHS glossary entry of `external')" + (:newline))) + (:newline) + ,(display-link "internal" internal-symbols internal-symbols-length + :title + (format nil "All internal symbols of package \"~A\"" + package-name) + :description + '("A symbol is considered internal of a package if it's" + (:newline) + "present and not external---that is if the package is" + (:newline) + "the home package of the symbol, or if the symbol has" + (:newline) + "been explicitly imported into the package." + (:newline) + (:newline) + "Notice that inherited symbols will thus not be listed," + (:newline) + "which deliberately deviates from the CLHS glossary" + (:newline) + "entry of `internal' because it's assumed to be more" + (:newline) + "useful this way." + (:newline))) + (:newline) + ,(display-link "inherited" inherited-symbols inherited-symbols-length + :title + (format nil "All inherited symbols of package \"~A\"" + package-name) + :description + '("A symbol is considered inherited in a package if it" + (:newline) + "was made accessible via USE-PACKAGE." + (:newline))) + (:newline) + ,(display-link "shadowed" shadowed-symbols (length shadowed-symbols) + :title + (format nil "All shadowed symbols of package \"~A\"" + package-name) + :description nil)))) + + +(defmethod emacs-inspect ((pathname pathname)) + `(,(if (wild-pathname-p pathname) + "A wild pathname." + "A pathname.") + (:newline) + ,@(label-value-line* + ("Namestring" (namestring pathname)) + ("Host" (pathname-host pathname)) + ("Device" (pathname-device pathname)) + ("Directory" (pathname-directory pathname)) + ("Name" (pathname-name pathname)) + ("Type" (pathname-type pathname)) + ("Version" (pathname-version pathname))) + ,@ (unless (or (wild-pathname-p pathname) + (not (probe-file pathname))) + (label-value-line "Truename" (truename pathname))))) + +(defmethod emacs-inspect ((pathname logical-pathname)) + (append + (label-value-line* + ("Namestring" (namestring pathname)) + ("Physical pathname: " (translate-logical-pathname pathname))) + `("Host: " + (:value ,(pathname-host pathname)) + " (" + (:value ,(logical-pathname-translations + (pathname-host pathname))) + " other translations)" + (:newline)) + (label-value-line* + ("Directory" (pathname-directory pathname)) + ("Name" (pathname-name pathname)) + ("Type" (pathname-type pathname)) + ("Version" (pathname-version pathname)) + ("Truename" (if (not (wild-pathname-p pathname)) + (probe-file pathname)))))) + +(defmethod emacs-inspect ((n number)) + `("Value: " ,(princ-to-string n))) + +(defun format-iso8601-time (time-value &optional include-timezone-p) + "Formats a universal time TIME-VALUE in ISO 8601 format, with + the time zone included if INCLUDE-TIMEZONE-P is non-NIL" + ;; Taken from http://www.pvv.ntnu.no/~nsaa/ISO8601.html + ;; Thanks, Nikolai Sandved and Thomas Russ! + (flet ((format-iso8601-timezone (zone) + (if (zerop zone) + "Z" + (multiple-value-bind (h m) (truncate (abs zone) 1.0) + ;; Tricky. Sign of time zone is reversed in ISO 8601 + ;; relative to Common Lisp convention! + (format nil "~:[+~;-~]~2,'0D:~2,'0D" + (> zone 0) h (round (* 60 m))))))) + (multiple-value-bind (second minute hour day month year dow dst zone) + (decode-universal-time time-value) + (declare (ignore dow)) + (format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D~:[~*~;~A~]" + year month day hour minute second + include-timezone-p (format-iso8601-timezone (if dst + (+ zone 1) + zone)))))) + +(defmethod emacs-inspect ((i integer)) + (append + `(,(format nil "Value: ~D = #x~8,'0X = #o~O = #b~,,' ,8:B~@[ = ~E~]" + i i i i (ignore-errors (coerce i 'float))) + (:newline)) + (when (< -1 i char-code-limit) + (label-value-line "Code-char" (code-char i))) + (label-value-line "Integer-length" (integer-length i)) + (ignore-errors + (label-value-line "Universal-time" (format-iso8601-time i t))))) + +(defmethod emacs-inspect ((c complex)) + (label-value-line* + ("Real part" (realpart c)) + ("Imaginary part" (imagpart c)))) + +(defmethod emacs-inspect ((r ratio)) + (label-value-line* + ("Numerator" (numerator r)) + ("Denominator" (denominator r)) + ("As float" (float r)))) + +(defmethod emacs-inspect ((f float)) + (cond + ((> f most-positive-long-float) + (list "Positive infinity.")) + ((< f most-negative-long-float) + (list "Negative infinity.")) + ((not (= f f)) + (list "Not a Number.")) + (t + (multiple-value-bind (significand exponent sign) (decode-float f) + (append + `("Scientific: " ,(format nil "~E" f) (:newline) + "Decoded: " + (:value ,sign) " * " + (:value ,significand) " * " + (:value ,(float-radix f)) "^" + (:value ,exponent) (:newline)) + (label-value-line "Digits" (float-digits f)) + (label-value-line "Precision" (float-precision f))))))) + +(defun make-pathname-ispec (pathname position) + `("Pathname: " + (:value ,pathname) + (:newline) " " + ,@(when position + `((:action "[visit file and show current position]" + ,(lambda () + (ed-in-emacs `(,pathname :position ,position :bytep t))) + :refreshp nil) + (:newline))))) + +(defun make-file-stream-ispec (stream) + ;; SBCL's socket stream are file-stream but are not associated to + ;; any pathname. + (let ((pathname (ignore-errors (pathname stream)))) + (when pathname + (make-pathname-ispec pathname (and (open-stream-p stream) + (file-position stream)))))) + +(defmethod emacs-inspect ((stream file-stream)) + (multiple-value-bind (content) + (call-next-method) + (append (make-file-stream-ispec stream) content))) + +(defmethod emacs-inspect ((condition stream-error)) + (multiple-value-bind (content) + (call-next-method) + (let ((stream (stream-error-stream condition))) + (append (when (typep stream 'file-stream) + (make-file-stream-ispec stream)) + content)))) + +(defun common-seperated-spec (list &optional (callback (lambda (v) + `(:value ,v)))) + (butlast + (loop + for i in list + collect (funcall callback i) + collect ", "))) + +(defun inspector-princ (list) + "Like princ-to-string, but don't rewrite (function foo) as #'foo. +Do NOT pass circular lists to this function." + (let ((*print-pprint-dispatch* (copy-pprint-dispatch))) + (set-pprint-dispatch '(cons (member function)) nil) + (princ-to-string list))) + +(provide :swank-fancy-inspector) diff --git a/vim/bundle/slimv/slime/contrib/swank-fuzzy.lisp b/vim/bundle/slimv/slime/contrib/swank-fuzzy.lisp new file mode 100644 index 0000000..bfd274f --- /dev/null +++ b/vim/bundle/slimv/slime/contrib/swank-fuzzy.lisp @@ -0,0 +1,706 @@ +;;; swank-fuzzy.lisp --- fuzzy symbol completion +;; +;; Authors: Brian Downing <bdowning@lavos.net> +;; Tobias C. Rittweiler <tcr@freebits.de> +;; and others +;; +;; License: Public Domain +;; + + +(in-package :swank) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (swank-require :swank-util) + (swank-require :swank-c-p-c)) + +(defvar *fuzzy-duplicate-symbol-filter* :nearest-package + "Specifies how fuzzy-matching handles \"duplicate\" symbols. +Possible values are :NEAREST-PACKAGE, :HOME-PACKAGE, :ALL, or a custom +function. See Fuzzy Completion in the manual for details.") + +(export '*fuzzy-duplicate-symbol-filter*) + +;;; For nomenclature of the fuzzy completion section, please read +;;; through the following docstring. + +(defslimefun fuzzy-completions (string default-package-name + &key limit time-limit-in-msec) +"Returns a list of two values: + + An (optionally limited to LIMIT best results) list of fuzzy + completions for a symbol designator STRING. The list will be + sorted by score, most likely match first. + + A flag that indicates whether or not TIME-LIMIT-IN-MSEC has + been exhausted during computation. If that parameter's value is + NIL or 0, no time limit is assumed. + +The main result is a list of completion objects, where a completion +object is: + + (COMPLETED-STRING SCORE (&rest CHUNKS) CLASSIFICATION-STRING) + +where a CHUNK is a description of a matched substring: + + (OFFSET SUBSTRING) + +and FLAGS is short string describing properties of the symbol (see +SYMBOL-CLASSIFICATION-STRING). + +E.g., completing \"mvb\" in a package that uses COMMON-LISP would +return something like: + + ((\"multiple-value-bind\" 26.588236 ((0 \"m\") (9 \"v\") (15 \"b\")) + (:FBOUNDP :MACRO)) + ...) + +If STRING is package qualified the result list will also be +qualified. If string is non-qualified the result strings are +also not qualified and are considered relative to +DEFAULT-PACKAGE-NAME. + +Which symbols are candidates for matching depends on the symbol +designator's format. The cases are as follows: + FOO - Symbols accessible in the buffer package. + PKG:FOO - Symbols external in package PKG. + PKG::FOO - Symbols accessible in package PKG." + ;; For Emacs we allow both NIL and 0 as value of TIME-LIMIT-IN-MSEC + ;; to denote an infinite time limit. Internally, we only use NIL for + ;; that purpose, to be able to distinguish between "no time limit + ;; alltogether" and "current time limit already exhausted." So we've + ;; got to canonicalize its value at first: + (let* ((no-time-limit-p (or (not time-limit-in-msec) + (zerop time-limit-in-msec))) + (time-limit (if no-time-limit-p nil time-limit-in-msec))) + (multiple-value-bind (completion-set interrupted-p) + (fuzzy-completion-set string default-package-name :limit limit + :time-limit-in-msec time-limit) + ;; We may send this as elisp [] arrays to spare a coerce here, + ;; but then the network serialization were slower by handling arrays. + ;; Instead we limit the number of completions that is transferred + ;; (the limit is set from Emacs.) + (list (coerce completion-set 'list) interrupted-p)))) + + +;;; A Fuzzy Matching -- Not to be confused with a fuzzy completion +;;; object that will be sent back to Emacs, as described above. + +(defstruct (fuzzy-matching (:conc-name fuzzy-matching.) + (:predicate fuzzy-matching-p) + (:constructor make-fuzzy-matching + (symbol package-name score package-chunks + symbol-chunks &key (symbol-p t)))) + symbol ; The symbol that has been found to match. + symbol-p ; To deffirentiate between completeing + ; package: and package:nil + package-name ; The name of the package where SYMBOL was found in. + ; (This is not necessarily the same as the home-package + ; of SYMBOL, because the SYMBOL can be internal to + ; lots of packages; also think of package nicknames.) + score ; The higher the better SYMBOL is a match. + package-chunks ; Chunks pertaining to the package identifier of SYMBOL. + symbol-chunks) ; Chunks pertaining to SYMBOL's name. + +(defun %fuzzy-extract-matching-info (fuzzy-matching user-input-string) + (multiple-value-bind (_ user-package-name __ input-internal-p) + (parse-completion-arguments user-input-string nil) + (declare (ignore _ __)) + (with-struct (fuzzy-matching. score symbol package-name package-chunks + symbol-chunks symbol-p) + fuzzy-matching + (let (symbol-name real-package-name internal-p) + (cond (symbol-p ; symbol fuzzy matching? + (setf symbol-name (symbol-name symbol)) + (setf internal-p input-internal-p) + (setf real-package-name (cond ((keywordp symbol) "") + ((not user-package-name) nil) + (t package-name)))) + (t ; package fuzzy matching? + (setf symbol-name "") + (setf real-package-name package-name) + ;; If no explicit package name was given by the user + ;; (e.g. input was "asdf"), we want to append only + ;; one colon ":" to the package names. + (setf internal-p (if user-package-name input-internal-p nil)))) + (values symbol-name + real-package-name + (if user-package-name internal-p nil) + (completion-output-symbol-converter user-input-string) + (completion-output-package-converter user-input-string)))))) + +(defun fuzzy-format-matching (fuzzy-matching user-input-string) + "Returns the completion (\"foo:bar\") that's represented by FUZZY-MATCHING." + (multiple-value-bind (symbol-name package-name internal-p + symbol-converter package-converter) + (%fuzzy-extract-matching-info fuzzy-matching user-input-string) + (setq symbol-name (and symbol-name + (funcall symbol-converter symbol-name))) + (setq package-name (and package-name + (funcall package-converter package-name))) + (let ((result (untokenize-symbol package-name internal-p symbol-name))) + ;; We return the length of the possibly added prefix as second value. + (values result (search symbol-name result))))) + +(defun fuzzy-convert-matching-for-emacs (fuzzy-matching user-input-string) + "Converts a result from the fuzzy completion core into something +that emacs is expecting. Converts symbols to strings, fixes case +issues, and adds information (as a string) describing if the symbol is +bound, fbound, a class, a macro, a generic-function, a +special-operator, or a package." + (with-struct (fuzzy-matching. symbol score package-chunks symbol-chunks + symbol-p) + fuzzy-matching + (multiple-value-bind (name added-length) + (fuzzy-format-matching fuzzy-matching user-input-string) + (list name + (format nil "~,2f" score) + (append package-chunks + (mapcar (lambda (chunk) + ;; Fix up chunk positions to account for possible + ;; added package identifier. + (let ((offset (first chunk)) + (string (second chunk))) + (list (+ added-length offset) string))) + symbol-chunks)) + (if symbol-p + (symbol-classification-string symbol) + "-------p"))))) + +(defun fuzzy-completion-set (string default-package-name + &key limit time-limit-in-msec) + "Returns two values: an array of completion objects, sorted by +their score, that is how well they are a match for STRING +according to the fuzzy completion algorithm. If LIMIT is set, +only the top LIMIT results will be returned. Additionally, a flag +is returned that indicates whether or not TIME-LIMIT-IN-MSEC was +exhausted." + (check-type limit (or null (integer 0 #.(1- most-positive-fixnum)))) + (check-type time-limit-in-msec + (or null (integer 0 #.(1- most-positive-fixnum)))) + (multiple-value-bind (matchings interrupted-p) + (fuzzy-generate-matchings string default-package-name time-limit-in-msec) + (when (and limit + (> limit 0) + (< limit (length matchings))) + (if (array-has-fill-pointer-p matchings) + (setf (fill-pointer matchings) limit) + (setf matchings (make-array limit :displaced-to matchings)))) + (map-into matchings #'(lambda (m) + (fuzzy-convert-matching-for-emacs m string)) + matchings) + (values matchings interrupted-p))) + + +(defun fuzzy-generate-matchings (string default-package-name + time-limit-in-msec) + "Does all the hard work for FUZZY-COMPLETION-SET. If +TIME-LIMIT-IN-MSEC is NIL, an infinite time limit is assumed." + (multiple-value-bind (parsed-symbol-name parsed-package-name + package internal-p) + (parse-completion-arguments string default-package-name) + (flet ((fix-up (matchings parent-package-matching) + ;; The components of each matching in MATCHINGS have been computed + ;; relatively to PARENT-PACKAGE-MATCHING. Make them absolute. + (let* ((p parent-package-matching) + (p.name (fuzzy-matching.package-name p)) + (p.score (fuzzy-matching.score p)) + (p.chunks (fuzzy-matching.package-chunks p))) + (map-into + matchings + (lambda (m) + (let ((m.score (fuzzy-matching.score m))) + (setf (fuzzy-matching.package-name m) p.name) + (setf (fuzzy-matching.package-chunks m) p.chunks) + (setf (fuzzy-matching.score m) + (if (equal parsed-symbol-name "") + ;; Make package matchings be sorted before all + ;; the relative symbol matchings while preserving + ;; over all orderness. + (/ p.score 100) + (+ p.score m.score))) + m)) + matchings))) + (find-symbols (designator package time-limit &optional filter) + (fuzzy-find-matching-symbols designator package + :time-limit-in-msec time-limit + :external-only (not internal-p) + :filter (or filter #'identity))) + (find-packages (designator time-limit) + (fuzzy-find-matching-packages designator + :time-limit-in-msec time-limit)) + (maybe-find-local-package (name) + (or (find-locally-nicknamed-package name *buffer-package*) + (find-package name)))) + (let ((time-limit time-limit-in-msec) (symbols) (packages) (results) + (dedup-table (make-hash-table :test #'equal))) + (cond ((not parsed-package-name) ; E.g. STRING = "asd" + ;; We don't know if user is searching for a package or a symbol + ;; within his current package. So we try to find either. + (setf (values packages time-limit) + (find-packages parsed-symbol-name time-limit)) + (setf (values symbols time-limit) + (find-symbols parsed-symbol-name package time-limit))) + ((string= parsed-package-name "") ; E.g. STRING = ":" or ":foo" + (setf (values symbols time-limit) + (find-symbols parsed-symbol-name package time-limit))) + (t ; E.g. STRING = "asd:" or "asd:foo" + ;; Find fuzzy matchings of the denoted package identifier part. + ;; After that, find matchings for the denoted symbol identifier + ;; relative to all the packages found. + (multiple-value-bind (symbol-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 symbol-packages + (sort symbol-packages #'fuzzy-matching-greaterp)) + (loop + for package-matching across symbol-packages + for package = (maybe-find-local-package + (fuzzy-matching.package-name + package-matching)) + while (or (not time-limit) (> rest-time-limit 0)) do + (multiple-value-bind (matchings remaining-time) + ;; The duplication filter removes all those symbols + ;; which are present in more than one package + ;; match. See *FUZZY-DUPLICATE-SYMBOL-FILTER* + (find-symbols parsed-symbol-name package rest-time-limit + (%make-duplicate-symbols-filter + package-matching symbol-packages dedup-table)) + (setf matchings (fix-up matchings package-matching)) + (setf symbols (concatenate 'vector symbols matchings)) + (setf rest-time-limit remaining-time) + (let ((guessed-sort-duration + (%guess-sort-duration (length symbols)))) + (when (and rest-time-limit + (<= rest-time-limit guessed-sort-duration)) + (decf rest-time-limit guessed-sort-duration) + (loop-finish)))) + finally + (setf time-limit rest-time-limit) + (when (equal parsed-symbol-name "") ; E.g. STRING = "asd:" + (setf packages symbol-packages)))))) + ;; Sort by score; thing with equal score, sort alphabetically. + ;; (Especially useful when PARSED-SYMBOL-NAME is empty, and all + ;; possible completions are to be returned.) + (setf results (concatenate 'vector symbols packages)) + (setf results (sort results #'fuzzy-matching-greaterp)) + (values results (and time-limit (<= time-limit 0))))))) + +(defun %guess-sort-duration (length) + ;; These numbers are pretty much arbitrary, except that they're + ;; vaguely correct on my machine with SBCL. Yes, this is an ugly + ;; kludge, but it's better than before (where this didn't exist at + ;; all, which essentially meant, that this was taken to be 0.) + (if (zerop length) + 0 + (let ((comparasions (* 3.8 (* length (log length 2))))) + (* 1000 (* comparasions (expt 10 -7)))))) ; msecs + +(defun %make-duplicate-symbols-filter (current-package-matching fuzzy-package-matchings dedup-table) + ;; Returns a filter function based on *FUZZY-DUPLICATE-SYMBOL-FILTER*. + (case *fuzzy-duplicate-symbol-filter* + (:home-package + ;; Return 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))) + (remove current-package-matching + (coerce fuzzy-package-matchings 'list))))) + #'(lambda (symbol) + (not (member (symbol-package symbol) packages))))) + (:nearest-package + ;; Keep only the first occurence of the symbol. + #'(lambda (symbol) + (unless (gethash (symbol-name symbol) dedup-table) + (setf (gethash (symbol-name symbol) dedup-table) t)))) + (:all + ;; No filter + #'identity) + (t + (typecase *fuzzy-duplicate-symbol-filter* + (function + ;; Custom filter + (funcall *fuzzy-duplicate-symbol-filter* + (fuzzy-matching.package-name current-package-matching) + (map 'list #'fuzzy-matching.package-name fuzzy-package-matchings) + dedup-table)) + (t + ;; Bad filter value + (warn "bad *FUZZY-DUPLICATE-SYMBOL-FILTER* value: ~s" + *fuzzy-duplicate-symbol-filter*) + #'identity))))) + +(defun fuzzy-matching-greaterp (m1 m2) + "Returns T if fuzzy-matching M1 should be sorted before M2. +Basically just the scores of the two matchings are compared, and +the match with higher score wins. For the case that the score is +equal, the one which comes alphabetically first wins." + (declare (type fuzzy-matching m1 m2)) + (let ((score1 (fuzzy-matching.score m1)) + (score2 (fuzzy-matching.score m2))) + (cond ((> score1 score2) t) + ((< score1 score2) nil) ; total order + (t + (let ((name1 (symbol-name (fuzzy-matching.symbol m1))) + (name2 (symbol-name (fuzzy-matching.symbol m2)))) + (string< name1 name2)))))) + +(declaim (ftype (function () (integer 0)) get-real-time-msecs)) +(defun get-real-time-in-msecs () + (let ((units-per-msec (max 1 (floor internal-time-units-per-second 1000)))) + (values (floor (get-internal-real-time) units-per-msec)))) + +(defun fuzzy-find-matching-symbols + (string package &key (filter #'identity) external-only time-limit-in-msec) + "Returns two values: a vector of fuzzy matchings for matching +symbols in PACKAGE, using the fuzzy completion algorithm, and the +remaining time limit. + +Only those symbols are considered of which FILTER does return T. + +If EXTERNAL-ONLY is true, only external symbols are considered. A +TIME-LIMIT-IN-MSEC of NIL is considered no limit; if it's zero or +negative, perform a NOP." + (let ((time-limit-p (and time-limit-in-msec t)) + (time-limit (or time-limit-in-msec 0)) + (rtime-at-start (get-real-time-in-msecs)) + (package-name (package-name package)) + (count 0)) + (declare (type boolean time-limit-p)) + (declare (type integer time-limit rtime-at-start)) + (declare (type (integer 0 #.(1- most-positive-fixnum)) count)) + + (flet ((recompute-remaining-time (old-remaining-time) + (cond ((not time-limit-p) + ;; propagate NIL back as infinite time limit + (values nil nil)) + ((> count 0) ; ease up on getting internal time like crazy + (setf count (mod (1+ count) 128)) + (values nil old-remaining-time)) + (t (let* ((elapsed-time (- (get-real-time-in-msecs) + rtime-at-start)) + (remaining (- time-limit elapsed-time))) + (values (<= remaining 0) remaining))))) + (perform-fuzzy-match (string symbol-name) + (let* ((converter (completion-output-symbol-converter string)) + (converted-symbol-name (funcall converter symbol-name))) + (compute-highest-scoring-completion string + converted-symbol-name)))) + (let ((completions (make-array 256 :adjustable t :fill-pointer 0)) + (rest-time-limit time-limit)) + (do-symbols* (symbol package) + (multiple-value-bind (exhausted? remaining-time) + (recompute-remaining-time rest-time-limit) + (setf rest-time-limit remaining-time) + (cond (exhausted? (return)) + ((not (and (or (not external-only) + (symbol-external-p symbol package)) + (funcall filter symbol)))) + ((string= "" string) ; "" matches always + (vector-push-extend + (make-fuzzy-matching symbol package-name + 0.0 '() '()) + completions)) + (t + (multiple-value-bind (match-result score) + (perform-fuzzy-match string (symbol-name symbol)) + (when match-result + (vector-push-extend + (make-fuzzy-matching symbol package-name score + '() match-result) + completions))))))) + (values completions rest-time-limit))))) + +(defun fuzzy-find-matching-packages (name &key time-limit-in-msec) + "Returns a vector of fuzzy matchings for each package that is +similiar to NAME, and the remaining time limit. +Cf. FUZZY-FIND-MATCHING-SYMBOLS." + (let ((time-limit-p (and time-limit-in-msec t)) + (time-limit (or time-limit-in-msec 0)) + (rtime-at-start (get-real-time-in-msecs)) + (converter (completion-output-package-converter name)) + (completions (make-array 32 :adjustable t :fill-pointer 0))) + (declare (type boolean time-limit-p)) + (declare (type integer time-limit rtime-at-start)) + (declare (type function converter)) + (flet ((match-package (names) + (loop with max-pkg-name = "" + with max-result = nil + with max-score = 0 + for package-name in names + for converted-name = (funcall converter package-name) + do + (multiple-value-bind (result score) + (compute-highest-scoring-completion name + converted-name) + (when (and result (> score max-score)) + (setf max-pkg-name package-name) + (setf max-result result) + (setf max-score score))) + finally + (when max-result + (vector-push-extend + (make-fuzzy-matching nil max-pkg-name + max-score max-result '() + :symbol-p nil) + completions))))) + (cond ((and time-limit-p (<= time-limit 0)) + (values #() time-limit)) + (t + (loop for (nick) in (package-local-nicknames *buffer-package*) + do + (match-package (list nick))) + (loop for package in (list-all-packages) + do + ;; Find best-matching package-nickname: + (match-package (package-names package)) + finally + (return + (values completions + (and time-limit-p + (let ((elapsed-time (- (get-real-time-in-msecs) + rtime-at-start))) + (- time-limit elapsed-time))))))))))) + + +(defslimefun fuzzy-completion-selected (original-string completion) + "This function is called by Slime when a fuzzy completion is +selected by the user. It is for future expansion to make +testing, say, a machine learning algorithm for completion scoring +easier. + +ORIGINAL-STRING is the string the user completed from, and +COMPLETION is the completion object (see docstring for +SWANK:FUZZY-COMPLETIONS) corresponding to the completion that the +user selected." + (declare (ignore original-string completion)) + nil) + + +;;;;; Fuzzy completion core + +(defparameter *fuzzy-recursion-soft-limit* 30 + "This is a soft limit for recursion in +RECURSIVELY-COMPUTE-MOST-COMPLETIONS. Without this limit, +completing a string such as \"ZZZZZZ\" with a symbol named +\"ZZZZZZZZZZZZZZZZZZZZZZZ\" will result in explosive recursion to +find all the ways it can match. + +Most natural language searches and symbols do not have this +problem -- this is only here as a safeguard.") +(declaim (fixnum *fuzzy-recursion-soft-limit*)) + +(defvar *all-chunks* '()) +(declaim (type list *all-chunks*)) + +(defun compute-highest-scoring-completion (short full) + "Finds the highest scoring way to complete the abbreviation +SHORT onto the string FULL, using CHAR= as a equality function for +letters. Returns two values: The first being the completion +chunks of the highest scorer, and the second being the score." + (let* ((scored-results + (mapcar #'(lambda (result) + (cons (score-completion result short full) result)) + (compute-most-completions short full))) + (winner (first (sort scored-results #'> :key #'first)))) + (values (rest winner) (first winner)))) + +(defun compute-most-completions (short full) + "Finds most possible ways to complete FULL with the letters in SHORT. +Calls RECURSIVELY-COMPUTE-MOST-COMPLETIONS recursively. Returns +a list of (&rest CHUNKS), where each CHUNKS is a description of +how a completion matches." + (let ((*all-chunks* nil)) + (recursively-compute-most-completions short full 0 0 nil nil nil t) + *all-chunks*)) + +(defun recursively-compute-most-completions + (short full + short-index initial-full-index + chunks current-chunk current-chunk-pos + recurse-p) + "Recursively (if RECURSE-P is true) find /most/ possible ways +to fuzzily map the letters in SHORT onto FULL, using CHAR= to +determine if two letters match. + +A chunk is a list of elements that have matched consecutively. +When consecutive matches stop, it is coerced into a string, +paired with the starting position of the chunk, and pushed onto +CHUNKS. + +Whenever a letter matches, if RECURSE-P is true, +RECURSIVELY-COMPUTE-MOST-COMPLETIONS calls itself with a position +one index ahead, to find other possibly higher scoring +possibilities. If there are less than +*FUZZY-RECURSION-SOFT-LIMIT* results in *ALL-CHUNKS* currently, +this call will also recurse. + +Once a word has been completely matched, the chunks are pushed +onto the special variable *ALL-CHUNKS* and the function returns." + (declare (optimize speed) + (type fixnum short-index initial-full-index) + (type list current-chunk) + (simple-string short full)) + (flet ((short-cur () + "Returns the next letter from the abbreviation, or NIL + if all have been used." + (if (= short-index (length short)) + nil + (aref short short-index))) + (add-to-chunk (char pos) + "Adds the CHAR at POS in FULL to the current chunk, + marking the start position if it is empty." + (unless current-chunk + (setf current-chunk-pos pos)) + (push char current-chunk)) + (collect-chunk () + "Collects the current chunk to CHUNKS and prepares for + a new chunk." + (when current-chunk + (let ((current-chunk-as-string + (nreverse + (make-array (length current-chunk) + :element-type 'character + :initial-contents current-chunk)))) + (push (list current-chunk-pos current-chunk-as-string) chunks) + (setf current-chunk nil + current-chunk-pos nil))))) + ;; If there's an outstanding chunk coming in collect it. Since + ;; we're recursively called on skipping an input character, the + ;; chunk can't possibly continue on. + (when current-chunk (collect-chunk)) + (do ((pos initial-full-index (1+ pos))) + ((= pos (length full))) + (let ((cur-char (aref full pos))) + (if (and (short-cur) + (char= cur-char (short-cur))) + (progn + (when recurse-p + ;; Try other possibilities, limiting insanely deep + ;; recursion somewhat. + (recursively-compute-most-completions + short full short-index (1+ pos) + chunks current-chunk current-chunk-pos + (not (> (length *all-chunks*) + *fuzzy-recursion-soft-limit*)))) + (incf short-index) + (add-to-chunk cur-char pos)) + (collect-chunk)))) + (collect-chunk) + ;; If we've exhausted the short characters we have a match. + (if (short-cur) + nil + (let ((rev-chunks (reverse chunks))) + (push rev-chunks *all-chunks*) + rev-chunks)))) + + +;;;;; Fuzzy completion scoring + +(defvar *fuzzy-completion-symbol-prefixes* "*+-%&?<" + "Letters that are likely to be at the beginning of a symbol. +Letters found after one of these prefixes will be scored as if +they were at the beginning of ths symbol.") +(defvar *fuzzy-completion-symbol-suffixes* "*+->" + "Letters that are likely to be at the end of a symbol. +Letters found before one of these suffixes will be scored as if +they were at the end of the symbol.") +(defvar *fuzzy-completion-word-separators* "-/." + "Letters that separate different words in symbols. Letters +after one of these symbols will be scores more highly than other +letters.") + +(defun score-completion (completion short full) + "Scores the completion chunks COMPLETION as a completion from +the abbreviation SHORT to the full string FULL. COMPLETION is a +list like: + ((0 \"mul\") (9 \"v\") (15 \"b\")) +Which, if SHORT were \"mulvb\" and full were \"multiple-value-bind\", +would indicate that it completed as such (completed letters +capitalized): + MULtiple-Value-Bind + +Letters are given scores based on their position in the string. +Letters at the beginning of a string or after a prefix letter at +the beginning of a string are scored highest. Letters after a +word separator such as #\- are scored next highest. Letters at +the end of a string or before a suffix letter at the end of a +string are scored medium, and letters anywhere else are scored +low. + +If a letter is directly after another matched letter, and its +intrinsic value in that position is less than a percentage of the +previous letter's value, it will use that percentage instead. + +Finally, a small scaling factor is applied to favor shorter +matches, all other things being equal." + (labels ((at-beginning-p (pos) + (= pos 0)) + (after-prefix-p (pos) + (and (= pos 1) + (find (aref full 0) *fuzzy-completion-symbol-prefixes*))) + (word-separator-p (pos) + (find (aref full pos) *fuzzy-completion-word-separators*)) + (after-word-separator-p (pos) + (find (aref full (1- pos)) *fuzzy-completion-word-separators*)) + (at-end-p (pos) + (= pos (1- (length full)))) + (before-suffix-p (pos) + (and (= pos (- (length full) 2)) + (find (aref full (1- (length full))) + *fuzzy-completion-symbol-suffixes*))) + (score-or-percentage-of-previous (base-score pos chunk-pos) + (if (zerop chunk-pos) + base-score + (max base-score + (+ (* (score-char (1- pos) (1- chunk-pos)) 0.85) + (expt 1.2 chunk-pos))))) + (score-char (pos chunk-pos) + (score-or-percentage-of-previous + (cond ((at-beginning-p pos) 10) + ((after-prefix-p pos) 10) + ((word-separator-p pos) 1) + ((after-word-separator-p pos) 8) + ((at-end-p pos) 6) + ((before-suffix-p pos) 6) + (t 1)) + pos chunk-pos)) + (score-chunk (chunk) + (loop for chunk-pos below (length (second chunk)) + for pos from (first chunk) + summing (score-char pos chunk-pos)))) + (let* ((chunk-scores (mapcar #'score-chunk completion)) + (length-score (/ 10.0 (1+ (- (length full) (length short)))))) + (values + (+ (reduce #'+ chunk-scores) length-score) + (list (mapcar #'list chunk-scores completion) length-score))))) + +(defun highlight-completion (completion full) + "Given a chunk definition COMPLETION and the string FULL, +HIGHLIGHT-COMPLETION will create a string that demonstrates where +the completion matched in the string. Matches will be +capitalized, while the rest of the string will be lower-case." + (let ((highlit (nstring-downcase (copy-seq full)))) + (dolist (chunk completion) + (setf highlit (nstring-upcase highlit + :start (first chunk) + :end (+ (first chunk) + (length (second chunk)))))) + highlit)) + +(defun format-fuzzy-completion-set (winners) + "Given a list of completion objects such as on returned by +FUZZY-COMPLETION-SET, format the list into user-readable output +for interactive debugging purpose." + (let ((max-len + (loop for winner in winners maximizing (length (first winner))))) + (loop for (sym score result) in winners do + (format t "~&~VA score ~8,2F ~A" + max-len (highlight-completion result sym) score result)))) + +(provide :swank-fuzzy) diff --git a/vim/bundle/slimv/slime/contrib/swank-hyperdoc.lisp b/vim/bundle/slimv/slime/contrib/swank-hyperdoc.lisp new file mode 100644 index 0000000..1e34a1d --- /dev/null +++ b/vim/bundle/slimv/slime/contrib/swank-hyperdoc.lisp @@ -0,0 +1,18 @@ +(in-package :swank) + +(defslimefun hyperdoc (string) + (let ((hyperdoc-package (find-package :hyperdoc))) + (when hyperdoc-package + (multiple-value-bind (symbol foundp symbol-name package) + (parse-symbol string *buffer-package*) + (declare (ignore symbol)) + (when foundp + (funcall (find-symbol (string :lookup) hyperdoc-package) + (package-name (if (member package (cons *buffer-package* + (package-use-list + *buffer-package*))) + *buffer-package* + package)) + symbol-name)))))) + +(provide :swank-hyperdoc) diff --git a/vim/bundle/slimv/slime/contrib/swank-indentation.lisp b/vim/bundle/slimv/slime/contrib/swank-indentation.lisp new file mode 100644 index 0000000..67e638d --- /dev/null +++ b/vim/bundle/slimv/slime/contrib/swank-indentation.lisp @@ -0,0 +1,140 @@ +(in-package :swank) + +(defvar *application-hints-tables* '() + "A list of hash tables mapping symbols to indentation hints (lists +of symbols and numbers as per cl-indent.el). Applications can add hash +tables to the list to change the auto indentation slime sends to +emacs.") + +(defun has-application-indentation-hint-p (symbol) + (let ((default (load-time-value (gensym)))) + (dolist (table *application-hints-tables*) + (let ((indentation (gethash symbol table default))) + (unless (eq default indentation) + (return-from has-application-indentation-hint-p + (values indentation t)))))) + (values nil nil)) + +(defun application-indentation-hint (symbol) + (let ((indentation (has-application-indentation-hint-p symbol))) + (labels ((walk (indentation-spec) + (etypecase indentation-spec + (null nil) + (number indentation-spec) + (symbol (string-downcase indentation-spec)) + (cons (cons (walk (car indentation-spec)) + (walk (cdr indentation-spec))))))) + (walk indentation)))) + +;;; override swank version of this function +(defun symbol-indentation (symbol) + "Return a form describing the indentation of SYMBOL. + +The form is to be used as the `common-lisp-indent-function' property +in Emacs." + (cond + ((has-application-indentation-hint-p symbol) + (application-indentation-hint symbol)) + ((and (macro-function symbol) + (not (known-to-emacs-p symbol))) + (let ((arglist (arglist symbol))) + (etypecase arglist + ((member :not-available) + nil) + (list + (macro-indentation arglist))))) + (t nil))) + +;;; More complex version. +(defun macro-indentation (arglist) + (labels ((frob (list &optional base) + (if (every (lambda (x) + (member x '(nil "&rest") :test #'equal)) + list) + ;; If there was nothing interesting, don't return anything. + nil + ;; Otherwise substitute leading NIL's with 4 or 1. + (let ((ok t)) + (substitute-if (if base + 4 + 1) + (lambda (x) + (if (and ok (not x)) + t + (setf ok nil))) + list)))) + (walk (list level &optional firstp) + (when (consp list) + (let ((head (car list))) + (if (consp head) + (let ((indent (frob (walk head (+ level 1) t)))) + (cons (list* "&whole" (if (zerop level) + 4 + 1) + indent) (walk (cdr list) level))) + (case head + ;; &BODY is &BODY, this is clear. + (&body + '("&body")) + ;; &KEY is tricksy. If it's at the base level, we want + ;; to indent them normally: + ;; + ;; (foo bar quux + ;; :quux t + ;; :zot nil) + ;; + ;; If it's at a destructuring level, we want indent of 1: + ;; + ;; (with-foo (var arg + ;; :foo t + ;; :quux nil) + ;; ...) + (&key + (if (zerop level) + '("&rest" nil) + '("&rest" 1))) + ;; &REST is tricksy. If it's at the front of + ;; destructuring, we want to indent by 1, otherwise + ;; normally: + ;; + ;; (foo (bar quux + ;; zot) + ;; ...) + ;; + ;; but + ;; + ;; (foo bar quux + ;; zot) + (&rest + (if (and (plusp level) firstp) + '("&rest" 1) + '("&rest" nil))) + ;; &WHOLE and &ENVIRONMENT are skipped as if they weren't there + ;; at all. + ((&whole &environment) + (walk (cddr list) level firstp)) + ;; &OPTIONAL is indented normally -- and the &OPTIONAL marker + ;; itself is not counted. + (&optional + (walk (cdr list) level)) + ;; Indent normally, walk the tail -- but + ;; unknown lambda-list keywords terminate the walk. + (otherwise + (unless (member head lambda-list-keywords) + (cons nil (walk (cdr list) level)))))))))) + (frob (walk arglist 0 t) t))) + +#+nil +(progn + (assert (equal '(4 4 ("&whole" 4 "&rest" 1) "&body") + (macro-indentation '(bar quux (&rest slots) &body body)))) + (assert (equal nil + (macro-indentation '(a b c &rest more)))) + (assert (equal '(4 4 4 "&body") + (macro-indentation '(a b c &body more)))) + (assert (equal '(("&whole" 4 1 1 "&rest" 1) "&body") + (macro-indentation '((name zot &key foo bar) &body body)))) + (assert (equal nil + (macro-indentation '(x y &key z))))) + +(provide :swank-indentation) diff --git a/vim/bundle/slimv/slime/contrib/swank-kawa.scm b/vim/bundle/slimv/slime/contrib/swank-kawa.scm new file mode 100644 index 0000000..843037b --- /dev/null +++ b/vim/bundle/slimv/slime/contrib/swank-kawa.scm @@ -0,0 +1,2498 @@ +;;;; swank-kawa.scm --- Swank server for Kawa +;;; +;;; Copyright (C) 2007 Helmut Eller +;;; +;;; This file is licensed under the terms of the GNU General Public +;;; License as distributed with Emacs (press C-h C-c for details). + +;;;; Installation +;; +;; 1. You need Kawa (version 2.x) and a JVM with debugger support. +;; +;; 2. Compile this file and create swank-kawa.jar with: +;; java -cp kawa.jar:$JAVA_HOME/lib/tools.jar \ +;; -Xss2M kawa.repl --r7rs -d classes -C swank-kawa.scm && +;; jar cf swank-kawa.jar -C classes . +;; +;; 3. Add something like this to your .emacs: +#| +;; Kawa, Swank, and the debugger classes (tools.jar) must be in the +;; classpath. You also need to start the debug agent. +(setq slime-lisp-implementations + '((kawa + ("java" + ;; needed jar files + "-cp" "kawa-2.0.1.jar:swank-kawa.jar:/opt/jdk1.8.0/lib/tools.jar" + ;; channel for debugger + "-agentlib:jdwp=transport=dt_socket,server=y,suspend=n" + ;; depending on JVM, compiler may need more stack + "-Xss2M" + ;; kawa without GUI + "kawa.repl" "-s") + :init kawa-slime-init))) + +(defun kawa-slime-init (file _) + (setq slime-protocol-version 'ignore) + (format "%S\n" + `(begin (import (swank-kawa)) + (start-swank ,file) + ;; Optionally add source paths of your code so + ;; that M-. works better: + ;;(set! swank-java-source-path + ;; (append + ;; '(,(expand-file-name "~/lisp/slime/contrib/") + ;; "/scratch/kawa") + ;; swank-java-source-path)) + ))) + +;; Optionally define a command to start it. +(defun kawa () + (interactive) + (slime 'kawa)) + +|# +;; 4. Start everything with M-- M-x slime kawa +;; +;; + + +;;; Code: + +(define-library (swank macros) + (export df fun seq set fin esc + ! !! !s @ @s + when unless while dotimes dolist for packing with pushf == assert + mif mcase mlet mlet* typecase ignore-errors + ferror + ) + (import (scheme base) + (only (kawa base) + syntax + quasisyntax + syntax-case + define-syntax-case + identifier? + + invoke + invoke-static + field + static-field + instance? + try-finally + try-catch + primitive-throw + + format + reverse! + as + )) + (begin " +(" + +(define (ferror fstring #!rest args) + (let ((err (<java.lang.Error> + (as <java.lang.String> (apply format fstring args))))) + (primitive-throw err))) + +(define (rewrite-lambda-list args) + (syntax-case args () + (() #`()) + ((rest x ...) (eq? #'rest #!rest) args) + ((optional x ...) (eq? #'optional #!optional) args) + ((var args ...) (identifier? #'var) + #`(var #,@(rewrite-lambda-list #'(args ...)))) + (((var type) args ...) (identifier? #'var) + #`((var :: type) #,@(rewrite-lambda-list #'(args ...)))))) + +(define-syntax df + (lambda (stx) + (syntax-case stx (=>) + ((df name (args ... => return-type) body ...) + #`(define (name #,@(rewrite-lambda-list #'(args ...))) :: return-type + (seq body ...))) + ((df name (args ...) body ...) + #`(define (name #,@(rewrite-lambda-list #'(args ...))) + (seq body ...)))))) + +(define-syntax fun + (lambda (stx) + (syntax-case stx (=>) + ((fun (args ... => return-type) body ...) + #`(lambda #,(rewrite-lambda-list #'(args ...)) :: return-type + (seq body ...))) + ((fun (args ...) body ...) + #`(lambda #,(rewrite-lambda-list #'(args ...)) + (seq body ...)))))) + +(define-syntax fin + (syntax-rules () + ((fin body handler ...) + (try-finally body (seq handler ...))))) + +(define-syntax seq + (syntax-rules () + ((seq) + (begin #!void)) + ((seq body ...) + (begin body ...)))) + +(define-syntax esc + (syntax-rules () + ((esc abort body ...) + (let* ((key (<symbol>)) + (abort (lambda (val) (throw key val)))) + (catch key + (lambda () body ...) + (lambda (key val) val)))))) + +(define-syntax ! + (syntax-rules () + ((! name obj args ...) + (invoke obj 'name args ...)))) + +(define-syntax !! + (syntax-rules () + ((!! name1 name2 obj args ...) + (! name1 (! name2 obj args ...))))) + +(define-syntax !s + (syntax-rules () + ((! class name args ...) + (invoke-static class 'name args ...)))) + +(define-syntax @ + (syntax-rules () + ((@ name obj) + (field obj 'name)))) + +(define-syntax @s + (syntax-rules (quote) + ((@s class name) + (static-field class (quote name))))) + +(define-syntax while + (syntax-rules () + ((while exp body ...) + (do () ((not exp)) body ...)))) + +(define-syntax dotimes + (syntax-rules () + ((dotimes (i n result) body ...) + (let ((max :: <int> n)) + (do ((i :: <int> 0 (as <int> (+ i 1)))) + ((= i max) result) + body ...))) + ((dotimes (i n) body ...) + (dotimes (i n #f) body ...)))) + +(define-syntax dolist + (syntax-rules () + ((dolist (e list) body ... ) + (for ((e list)) body ...)))) + +(define-syntax for + (syntax-rules () + ((for ((var iterable)) body ...) + (let ((iter (! iterator iterable))) + (while (! has-next iter) + ((lambda (var) body ...) + (! next iter))))))) + +(define-syntax packing + (syntax-rules () + ((packing (var) body ...) + (let ((var :: <list> '())) + (let ((var (lambda (v) (set! var (cons v var))))) + body ...) + (reverse! var))))) + +;;(define-syntax loop +;; (syntax-rules (for = then collect until) +;; ((loop for var = init then step until test collect exp) +;; (packing (pack) +;; (do ((var init step)) +;; (test) +;; (pack exp)))) +;; ((loop while test collect exp) +;; (packing (pack) (while test (pack exp)))))) + +(define-syntax with + (syntax-rules () + ((with (vars ... (f args ...)) body ...) + (f args ... (lambda (vars ...) body ...))))) + +(define-syntax pushf + (syntax-rules () + ((pushf value var) + (set! var (cons value var))))) + +(define-syntax == + (syntax-rules () + ((== x y) + (eq? x y)))) + +(define-syntax set + (syntax-rules () + ((set x y) + (let ((tmp y)) + (set! x tmp) + tmp)) + ((set x y more ...) + (begin (set! x y) (set more ...))))) + +(define-syntax assert + (syntax-rules () + ((assert test) + (seq + (when (not test) + (error "Assertion failed" 'test)) + 'ok)) + ((assert test fstring args ...) + (seq + (when (not test) + (error "Assertion failed" 'test (format #f fstring args ...))) + 'ok)))) + +(define-syntax mif + (syntax-rules (quote unquote _) + ((mif ('x value) then else) + (if (equal? 'x value) then else)) + ((mif (,x value) then else) + (if (eq? x value) then else)) + ((mif (() value) then else) + (if (eq? value '()) then else)) + #| This variant produces no lambdas but breaks the compiler + ((mif ((p . ps) value) then else) + (let ((tmp value) + (fail? :: <int> 0) + (result #!null)) + (if (instance? tmp <pair>) + (let ((tmp :: <pair> tmp)) + (mif (p (! get-car tmp)) + (mif (ps (! get-cdr tmp)) + (set! result then) + (set! fail? -1)) + (set! fail? -1))) + (set! fail? -1)) + (if (= fail? 0) result else))) + |# + ((mif ((p . ps) value) then else) + (let ((fail (lambda () else)) + (tmp value)) + (if (instance? tmp <pair>) + (let ((tmp :: <pair> tmp)) + (mif (p (! get-car tmp)) + (mif (ps (! get-cdr tmp)) + then + (fail)) + (fail))) + (fail)))) + ((mif (_ value) then else) + then) + ((mif (var value) then else) + (let ((var value)) then)) + ((mif (pattern value) then) + (mif (pattern value) then (values))))) + +(define-syntax mcase + (syntax-rules () + ((mcase exp (pattern body ...) more ...) + (let ((tmp exp)) + (mif (pattern tmp) + (begin body ...) + (mcase tmp more ...)))) + ((mcase exp) (ferror "mcase failed ~s\n~a" 'exp exp)))) + +(define-syntax mlet + (syntax-rules () + ((mlet (pattern value) body ...) + (let ((tmp value)) + (mif (pattern tmp) + (begin body ...) + (error "mlet failed" tmp)))))) + +(define-syntax mlet* + (syntax-rules () + ((mlet* () body ...) (begin body ...)) + ((mlet* ((pattern value) ms ...) body ...) + (mlet (pattern value) (mlet* (ms ...) body ...))))) + +(define-syntax typecase% + (syntax-rules (eql or satisfies) + ((typecase% var (#t body ...) more ...) + (seq body ...)) + ((typecase% var ((eql value) body ...) more ...) + (cond ((eqv? var 'value) body ...) + (else (typecase% var more ...)))) + ((typecase% var ((satisfies predicate) body ...) more ...) + (cond ((predicate var) body ...) + (else (typecase% var more ...)))) + ((typecase% var ((or type) body ...) more ...) + (typecase% var (type body ...) more ...)) + ((typecase% var ((or type ...) body ...) more ...) + (let ((f (lambda (var) body ...))) + (typecase% var + (type (f var)) ... + (#t (typecase% var more ...))))) + ((typecase% var (type body ...) more ...) + (cond ((instance? var type) + (let ((var :: type (as type var))) + body ...)) + (else (typecase% var more ...)))) + ((typecase% var) + (error "typecase% failed" var + (! getClass (as <object> var)))))) + +(define-syntax typecase + (lambda (stx) + (syntax-case stx () + ((_ exp more ...) (identifier? (syntax exp)) + #`(typecase% exp more ...)) + ((_ exp more ...) + #`(let ((tmp exp)) + (typecase% tmp more ...)))))) + +(define-syntax ignore-errors + (syntax-rules () + ((ignore-errors body ...) + (try-catch (seq body ...) + (v <java.lang.Error> #f) + (v <java.lang.Exception> #f))))) + +)) + +(define-library (swank-kawa) + (export start-swank + create-swank-server + swank-java-source-path + break) + (import (scheme base) + (scheme file) + (scheme repl) + (scheme read) + (scheme write) + (scheme eval) + (scheme process-context) + (swank macros) + (only (kawa base) + + define-alias + define-variable + + define-simple-class + this + + invoke-special + instance? + as + + primitive-throw + try-finally + try-catch + synchronized + + call-with-input-string + call-with-output-string + force-output + format + + make-process + command-parse + + runnable + + scheme-implementation-version + reverse! + ) + (rnrs hashtables) + (only (gnu kawa slib syntaxutils) expand) + (only (kawa regex) regex-match)) + (begin " +(" + + +;;(define-syntax dc +;; (syntax-rules () +;; ((dc name () %% (props ...) prop more ...) +;; (dc name () %% (props ... (prop <object>)) more ...)) +;; ;;((dc name () %% (props ...) (prop type) more ...) +;; ;; (dc name () %% (props ... (prop type)) more ...)) +;; ((dc name () %% ((prop type) ...)) +;; (define-simple-class name () +;; ((*init* (prop :: type) ...) +;; (set (field (this) 'prop) prop) ...) +;; (prop :type type) ...)) +;; ((dc name () props ...) +;; (dc name () %% () props ...)))) + + +;;;; Aliases + +(define-alias <server-socket> java.net.ServerSocket) +(define-alias <socket> java.net.Socket) +(define-alias <in> java.io.InputStreamReader) +(define-alias <out> java.io.OutputStreamWriter) +(define-alias <in-port> gnu.kawa.io.InPort) +(define-alias <out-port> gnu.kawa.io.OutPort) +(define-alias <file> java.io.File) +(define-alias <str> java.lang.String) +(define-alias <builder> java.lang.StringBuilder) +(define-alias <throwable> java.lang.Throwable) +(define-alias <source-error> gnu.text.SourceError) +(define-alias <module-info> gnu.expr.ModuleInfo) +(define-alias <iterable> java.lang.Iterable) +(define-alias <thread> java.lang.Thread) +(define-alias <queue> java.util.concurrent.LinkedBlockingQueue) +(define-alias <exchanger> java.util.concurrent.Exchanger) +(define-alias <timeunit> java.util.concurrent.TimeUnit) +(define-alias <vm> com.sun.jdi.VirtualMachine) +(define-alias <mirror> com.sun.jdi.Mirror) +(define-alias <value> com.sun.jdi.Value) +(define-alias <thread-ref> com.sun.jdi.ThreadReference) +(define-alias <obj-ref> com.sun.jdi.ObjectReference) +(define-alias <array-ref> com.sun.jdi.ArrayReference) +(define-alias <str-ref> com.sun.jdi.StringReference) +(define-alias <meth-ref> com.sun.jdi.Method) +(define-alias <class-type> com.sun.jdi.ClassType) +(define-alias <ref-type> com.sun.jdi.ReferenceType) +(define-alias <frame> com.sun.jdi.StackFrame) +(define-alias <field> com.sun.jdi.Field) +(define-alias <local-var> com.sun.jdi.LocalVariable) +(define-alias <location> com.sun.jdi.Location) +(define-alias <absent-exc> com.sun.jdi.AbsentInformationException) +(define-alias <event> com.sun.jdi.event.Event) +(define-alias <exception-event> com.sun.jdi.event.ExceptionEvent) +(define-alias <step-event> com.sun.jdi.event.StepEvent) +(define-alias <breakpoint-event> com.sun.jdi.event.BreakpointEvent) +(define-alias <env> gnu.mapping.Environment) + +(define-simple-class <chan> () + (owner :: <thread> #:init (!s java.lang.Thread currentThread)) + (peer :: <chan>) + (queue :: <queue> #:init (<queue>)) + (lock #:init (<object>))) + + +;;;; Entry Points + +(df create-swank-server (port-number) + (setup-server port-number announce-port)) + +(df start-swank (port-file) + (let ((announce (fun ((socket <server-socket>)) + (with (f (call-with-output-file port-file)) + (format f "~d\n" (! get-local-port socket)))))) + (spawn (fun () + (setup-server 0 announce))))) + +(df setup-server ((port-number <int>) announce) + (! set-name (current-thread) "swank") + (let ((s (<server-socket> port-number))) + (announce s) + (let ((c (! accept s))) + (! close s) + (log "connection: ~s\n" c) + (fin (dispatch-events c) + (log "closing socket: ~a\n" s) + (! close c))))) + +(df announce-port ((socket <server-socket>)) + (log "Listening on port: ~d\n" (! get-local-port socket))) + + +;;;; Event dispatcher + +(define-variable *the-vm* #f) +(define-variable *last-exception* #f) +(define-variable *last-stacktrace* #f) +(df %vm (=> <vm>) *the-vm*) + +;; FIXME: this needs factorization. But I guess the whole idea of +;; using bidirectional channels just sucks. Mailboxes owned by a +;; single thread to which everybody can send are much easier to use. + +(df dispatch-events ((s <socket>)) + (mlet* ((charset "iso-8859-1") + (ins (<in> (! getInputStream s) charset)) + (outs (<out> (! getOutputStream s) charset)) + ((in . _) (spawn/chan/catch (fun (c) (reader ins c)))) + ((out . _) (spawn/chan/catch (fun (c) (writer outs c)))) + ((dbg . _) (spawn/chan/catch vm-monitor)) + (user-env (interaction-environment)) + (x (seq + (! set-flag user-env #t #|<env>:THREAD_SAFE|# 8) + (! set-flag user-env #f #|<env>:DIRECT_INHERITED_ON_SET|# 16) + #f)) + ((listener . _) + (spawn/chan (fun (c) (listener c user-env)))) + (inspector #f) + (threads '()) + (repl-thread #f) + (extra '()) + (vm (let ((vm #f)) (fun () (or vm (rpc dbg `(get-vm))))))) + (while #t + (mlet ((c . event) (recv* (append (list in out dbg listener) + (if inspector (list inspector) '()) + (map car threads) + extra))) + ;;(log "event: ~s\n" event) + (mcase (list c event) + ((_ (':emacs-rex ('|swank:debugger-info-for-emacs| from to) + pkg thread id)) + (send dbg `(debug-info ,thread ,from ,to ,id))) + ((_ (':emacs-rex ('|swank:throw-to-toplevel|) pkg thread id)) + (send dbg `(throw-to-toplevel ,thread ,id))) + ((_ (':emacs-rex ('|swank:sldb-continue|) pkg thread id)) + (send dbg `(thread-continue ,thread ,id))) + ((_ (':emacs-rex ('|swank:frame-source-location| frame) + pkg thread id)) + (send dbg `(frame-src-loc ,thread ,frame ,id))) + ((_ (':emacs-rex ('|swank:frame-locals-and-catch-tags| frame) + pkg thread id)) + (send dbg `(frame-details ,thread ,frame ,id))) + ((_ (':emacs-rex ('|swank:sldb-disassemble| frame) + pkg thread id)) + (send dbg `(disassemble-frame ,thread ,frame ,id))) + ((_ (':emacs-rex ('|swank:backtrace| from to) pkg thread id)) + (send dbg `(thread-frames ,thread ,from ,to ,id))) + ((_ (':emacs-rex ('|swank:list-threads|) pkg thread id)) + (send dbg `(list-threads ,id))) + ((_ (':emacs-rex ('|swank:debug-nth-thread| n) _ _ _)) + (send dbg `(debug-nth-thread ,n))) + ((_ (':emacs-rex ('|swank:quit-thread-browser|) _ _ id)) + (send dbg `(quit-thread-browser ,id))) + ((_ (':emacs-rex ('|swank:init-inspector| str . _) pkg _ id)) + (set inspector (make-inspector user-env (vm))) + (send inspector `(init ,str ,id))) + ((_ (':emacs-rex ('|swank:inspect-frame-var| frame var) + pkg thread id)) + (mlet ((im . ex) (chan)) + (set inspector (make-inspector user-env (vm))) + (send dbg `(get-local ,ex ,thread ,frame ,var)) + (send inspector `(init-mirror ,im ,id)))) + ((_ (':emacs-rex ('|swank:inspect-current-condition|) pkg thread id)) + (mlet ((im . ex) (chan)) + (set inspector (make-inspector user-env (vm))) + (send dbg `(get-exception ,ex ,thread)) + (send inspector `(init-mirror ,im ,id)))) + ((_ (':emacs-rex ('|swank:inspect-nth-part| n) pkg _ id)) + (send inspector `(inspect-part ,n ,id))) + ((_ (':emacs-rex ('|swank:inspector-pop|) pkg _ id)) + (send inspector `(pop ,id))) + ((_ (':emacs-rex ('|swank:quit-inspector|) pkg _ id)) + (send inspector `(quit ,id))) + ((_ (':emacs-interrupt id)) + (let* ((vm (vm)) + (t (find-thread id (map cdr threads) repl-thread vm))) + (send dbg `(interrupt-thread ,t)))) + ((_ (':emacs-rex form _ _ id)) + (send listener `(,form ,id))) + ((_ ('get-vm c)) + (send dbg `(get-vm ,c))) + ((_ ('get-channel c)) + (mlet ((im . ex) (chan)) + (pushf im extra) + (send c ex))) + ((_ ('forward x)) + (send out x)) + ((_ ('set-listener x)) + (set repl-thread x)) + ((_ ('publish-vm vm)) + (set *the-vm* vm)) + ))))) + +(df find-thread (id threads listener (vm <vm>)) + (cond ((== id ':repl-thread) listener) + ((== id 't) listener + ;;(if (null? threads) + ;; listener + ;; (vm-mirror vm (car threads))) + ) + (#t + (let ((f (find-if threads + (fun (t :: <thread>) + (= id (! uniqueID + (as <thread-ref> (vm-mirror vm t))))) + #f))) + (cond (f (vm-mirror vm f)) + (#t listener)))))) + + +;;;; Reader thread + +(df reader ((in <in>) (c <chan>)) + (! set-name (current-thread) "swank-net-reader") + (let ((rt (!s gnu.kawa.lispexpr.ReadTable createInitial))) ; ':' not special + (while #t + (send c (decode-message in rt))))) + +(df decode-message ((in <in>) (rt <gnu.kawa.lispexpr.ReadTable>) => <list>) + (let* ((header (read-chunk in 6)) + (len (!s java.lang.Integer parseInt header 16))) + (call-with-input-string (read-chunk in len) + (fun ((port <input-port>)) + (%read port rt))))) + +(df read-chunk ((in <in>) (len <int>) => <str>) + (let ((chars (<char[]> #:length len))) + (let loop ((offset :: <int> 0)) + (cond ((= offset len) (<str> chars)) + (#t (let ((count (! read in chars offset (- len offset)))) + (assert (not (= count -1)) "partial packet") + (loop (+ offset count)))))))) + +;;; FIXME: not thread safe +(df %read ((port <in-port>) (table <gnu.kawa.lispexpr.ReadTable>)) + (let ((old (!s gnu.kawa.lispexpr.ReadTable getCurrent))) + (try-finally + (seq (!s gnu.kawa.lispexpr.ReadTable setCurrent table) + (read port)) + (!s gnu.kawa.lispexpr.ReadTable setCurrent old)))) + + +;;;; Writer thread + +(df writer ((out <out>) (c <chan>)) + (! set-name (current-thread) "swank-net-writer") + (while #t + (encode-message out (recv c)))) + +(df encode-message ((out <out>) (message <list>)) + (let ((builder (<builder> (as <int> 512)))) + (print-for-emacs message builder) + (! write out (! toString (format "~6,'0x" (! length builder)))) + (! write out builder) + (! flush out))) + +(df print-for-emacs (obj (out <builder>)) + (let ((pr (fun (o) (! append out (! toString (format "~s" o))))) + (++ (fun ((s <string>)) (! append out (! toString s))))) + (cond ((null? obj) (++ "nil")) + ((string? obj) (pr obj)) + ((number? obj) (pr obj)) + ;;((keyword? obj) (++ ":") (! append out (to-str obj))) + ((symbol? obj) (pr obj)) + ((pair? obj) + (++ "(") + (let loop ((obj obj)) + (print-for-emacs (car obj) out) + (let ((cdr (cdr obj))) + (cond ((null? cdr) (++ ")")) + ((pair? cdr) (++ " ") (loop cdr)) + (#t (++ " . ") (print-for-emacs cdr out) (++ ")")))))) + (#t (error "Unprintable object" obj))))) + +;;;; SLIME-EVAL + +(df eval-for-emacs ((form <list>) env (id <int>) (c <chan>)) + ;;(! set-uncaught-exception-handler (current-thread) + ;; (<ucex-handler> (fun (t e) (reply-abort c id)))) + (reply c (%eval form env) id)) + +(define-variable *slime-funs*) +(set *slime-funs* (tab)) + +(df %eval (form env) + (apply (lookup-slimefun (car form) *slime-funs*) env (cdr form))) + +(df lookup-slimefun ((name <symbol>) tab) + ;; name looks like '|swank:connection-info| + (or (get tab name #f) + (ferror "~a not implemented" name))) + +(df %defslimefun ((name <symbol>) (fun <procedure>)) + (let ((string (symbol->string name))) + (cond ((regex-match #/:/ string) + (put *slime-funs* name fun)) + (#t + (let ((qname (string->symbol (string-append "swank:" string)))) + (put *slime-funs* qname fun)))))) + +(define-syntax defslimefun + (syntax-rules () + ((defslimefun name (args ...) body ...) + (seq + (df name (args ...) body ...) + (%defslimefun 'name name))))) + +(defslimefun connection-info ((env <env>)) + (let ((prop (fun (name) (!s java.lang.System getProperty name)))) + `(:pid + 0 + :style :spawn + :lisp-implementation (:type "Kawa" :name "kawa" + :version ,(scheme-implementation-version)) + :machine (:instance ,(prop "java.vm.name") :type ,(prop "os.name") + :version ,(prop "java.runtime.version")) + :features () + :package (:name "??" :prompt ,(! getName env)) + :encoding (:coding-systems ("iso-8859-1")) + ))) + + +;;;; Listener + +(df listener ((c <chan>) (env <env>)) + (! set-name (current-thread) "swank-listener") + (log "listener: ~s ~s ~s ~s\n" + (current-thread) (! hashCode (current-thread)) c env) + (let ((out (make-swank-outport (rpc c `(get-channel))))) + (set (current-output-port) out) + (let ((vm (as <vm> (rpc c `(get-vm))))) + (send c `(set-listener ,(vm-mirror vm (current-thread)))) + (request-uncaught-exception-events vm) + ;;stack snaphost are too expensive + ;;(request-caught-exception-events vm) + ) + (rpc c `(get-vm)) + (listener-loop c env out))) + +(define-simple-class <listener-abort> (<throwable>) + ((*init*) + (invoke-special <throwable> (this) '*init* )) + ((abort) :: void + (primitive-throw (this)))) + +(df listener-loop ((c <chan>) (env <env>) port) + (while (not (nul? c)) + ;;(log "listener-loop: ~s ~s\n" (current-thread) c) + (mlet ((form id) (recv c)) + (let ((restart (fun () + (close-port port) + (reply-abort c id) + (send (car (spawn/chan + (fun (cc) + (listener (recv cc) env)))) + c) + (set c #!null)))) + (! set-uncaught-exception-handler (current-thread) + (<ucex-handler> (fun (t e) (restart)))) + (try-catch + (let* ((val (%eval form env))) + (force-output) + (reply c val id)) + (ex <java.lang.Exception> (invoke-debugger ex) (restart)) + (ex <java.lang.Error> (invoke-debugger ex) (restart)) + (ex <listener-abort> + (let ((flag (!s java.lang.Thread interrupted))) + (log "listener-abort: ~s ~a\n" ex flag)) + (restart)) + ))))) + +(df invoke-debugger (condition) + ;;(log "should now invoke debugger: ~a" condition) + (try-catch + (break condition) + (ex <listener-abort> (seq)))) + +(defslimefun |swank-repl:create-repl| (env #!rest _) + (list "user" "user")) + +(defslimefun interactive-eval (env str) + (values-for-echo-area (eval (read-from-string str) env))) + +(defslimefun interactive-eval-region (env (s <string>)) + (with (port (call-with-input-string s)) + (values-for-echo-area + (let next ((result (values))) + (let ((form (read port))) + (cond ((== form #!eof) result) + (#t (next (eval form env))))))))) + +(defslimefun |swank-repl:listener-eval| (env string) + (let* ((form (read-from-string string)) + (list (values-to-list (eval form env)))) + `(:values ,@(map pprint-to-string list)))) + +(defslimefun pprint-eval (env string) + (let* ((form (read-from-string string)) + (l (values-to-list (eval form env)))) + (apply cat (map pprint-to-string l)))) + +(df call-with-abort (f) + (try-catch (f) (ex <throwable> (exception-message ex)))) + +(df exception-message ((ex <throwable>)) + (typecase ex + (<kawa.lang.NamedException> (! to-string ex)) + (<throwable> (format "~a: ~a" + (class-name-sans-package ex) + (! getMessage ex))))) + +(df values-for-echo-area (values) + (let ((values (values-to-list values))) + (cond ((null? values) "; No value") + (#t (format "~{~a~^, ~}" (map pprint-to-string values)))))) + +;;;; Compilation + +(defslimefun compile-file-for-emacs (env (filename <str>) load? + #!optional options) + (let ((jar (cat (path-sans-extension (filepath filename)) ".jar"))) + (wrap-compilation + (fun ((m <gnu.text.SourceMessages>)) + (!s kawa.lang.CompileFile read filename m)) + jar (if (lisp-bool load?) env #f) #f))) + +(df wrap-compilation (f jar env delete?) + (let ((start-time (current-time)) + (messages (<gnu.text.SourceMessages>))) + (try-catch + (let ((c (as <gnu.expr.Compilation> (f messages)))) + (set (@ explicit c) #t) + (! compile-to-archive c (! get-module c) jar)) + (ex <throwable> + (log "error during compilation: ~a\n~a" ex (! getStackTrace ex)) + (! error messages (as <char> #\f) + (to-str (exception-message ex)) #!null) + #f)) + (log "compilation done.\n") + (let ((success? (zero? (! get-error-count messages)))) + (when (and env success?) + (log "loading ...\n") + (eval `(load ,jar) env) + (log "loading ... done.\n")) + (when delete? + (ignore-errors (delete-file jar) #f)) + (let ((end-time (current-time))) + (list ':compilation-result + (compiler-notes-for-emacs messages) + (if success? 't 'nil) + (/ (- end-time start-time) 1000.0)))))) + +(defslimefun compile-string-for-emacs (env string buffer offset dir) + (wrap-compilation + (fun ((m <gnu.text.SourceMessages>)) + (let ((c (as <gnu.expr.Compilation> + (call-with-input-string + string + (fun ((p <in-port>)) + (! set-path p + (format "~s" + `(buffer ,buffer offset ,offset str ,string))) + (!s kawa.lang.CompileFile read p m)))))) + (let ((o (@ currentOptions c))) + (! set o "warn-invoke-unknown-method" #t) + (! set o "warn-undefined-variable" #t)) + (let ((m (! getModule c))) + (! set-name m (format "<emacs>:~a/~a" buffer (current-time)))) + c)) + "/tmp/kawa-tmp.zip" env #t)) + +(df compiler-notes-for-emacs ((messages <gnu.text.SourceMessages>)) + (packing (pack) + (do ((e (! get-errors messages) (@ next e))) + ((nul? e)) + (pack (source-error>elisp e))))) + +(df source-error>elisp ((e <source-error>) => <list>) + (list ':message (to-string (@ message e)) + ':severity (case (integer->char (@ severity e)) + ((#\e #\f) ':error) + ((#\w) ':warning) + (else ':note)) + ':location (error-loc>elisp e))) + +(df error-loc>elisp ((e <source-error>)) + (cond ((nul? (@ filename e)) `(:error "No source location")) + ((! starts-with (@ filename e) "(buffer ") + (mlet (('buffer b 'offset ('quote ((:position o) _)) 'str s) + (read-from-string (@ filename e))) + (let ((off (line>offset (1- (@ line e)) s)) + (col (1- (@ column e)))) + `(:location (:buffer ,b) (:position ,(+ o off col)) nil)))) + (#t + `(:location (:file ,(to-string (@ filename e))) + (:line ,(@ line e) ,(1- (@ column e))) + nil)))) + +(df line>offset ((line <int>) (s <str>) => <int>) + (let ((offset :: <int> 0)) + (dotimes (i line) + (set offset (! index-of s (as <char> #\newline) offset)) + (assert (>= offset 0)) + (set offset (as <int> (+ offset 1)))) + (log "line=~a offset=~a\n" line offset) + offset)) + +(defslimefun load-file (env filename) + (format "Loaded: ~a => ~s" filename (eval `(load ,filename) env))) + +;;;; Completion + +(defslimefun simple-completions (env (pattern <str>) _) + (let* ((env (as <gnu.mapping.InheritingEnvironment> env)) + (matches (packing (pack) + (let ((iter (! enumerate-all-locations env))) + (while (! has-next iter) + (let ((l (! next-location iter))) + (typecase l + (<gnu.mapping.NamedLocation> + (let ((name (!! get-name get-key-symbol l))) + (when (! starts-with name pattern) + (pack name))))))))))) + `(,matches ,(cond ((null? matches) pattern) + (#t (fold+ common-prefix matches)))))) + +(df common-prefix ((s1 <str>) (s2 <str>) => <str>) + (let ((limit (min (! length s1) (! length s2)))) + (let loop ((i 0)) + (cond ((or (= i limit) + (not (== (! char-at s1 i) + (! char-at s2 i)))) + (! substring s1 0 i)) + (#t (loop (1+ i))))))) + +(df fold+ (f list) + (let loop ((s (car list)) + (l (cdr list))) + (cond ((null? l) s) + (#t (loop (f s (car l)) (cdr l)))))) + +;;; Quit + +(defslimefun quit-lisp (env) + (exit)) + +;;(defslimefun set-default-directory (env newdir)) + + +;;;; Dummy defs + +(defslimefun buffer-first-change (#!rest y) '()) +(defslimefun swank-require (#!rest y) '()) +(defslimefun frame-package-name (#!rest y) '()) + +;;;; arglist + +(defslimefun operator-arglist (env name #!rest _) + (mcase (try-catch `(ok ,(eval (read-from-string name) env)) + (ex <throwable> 'nil)) + (('ok obj) + (mcase (arglist obj) + ('#f 'nil) + ((args rtype) + (format "(~a~{~^ ~a~})~a" name + (map (fun (e) + (if (equal (cadr e) "java.lang.Object") (car e) e)) + args) + (if (equal rtype "java.lang.Object") + "" + (format " => ~a" rtype)))))) + (_ 'nil))) + +(df arglist (obj) + (typecase obj + (<gnu.expr.ModuleMethod> + (let* ((mref (module-method>meth-ref obj))) + (list (mapi (! arguments mref) + (fun ((v <local-var>)) + (list (! name v) (! typeName v)))) + (! returnTypeName mref)))) + (<object> #f))) + +;;;; M-. + +(defslimefun find-definitions-for-emacs (env name) + (mcase (try-catch `(ok ,(eval (read-from-string name) env)) + (ex <throwable> `(error ,(exception-message ex)))) + (('ok obj) (mapi (all-definitions obj) + (fun (d) + `(,(format "~a" d) ,(src-loc>elisp (src-loc d)))))) + (('error msg) `((,name (:error ,msg)))))) + +(define-simple-class <swank-location> (<location>) + (file #:init #f) + (line #:init #f) + ((*init* file name) + (set (@ file (this)) file) + (set (@ line (this)) line)) + ((lineNumber) :: <int> (or line (absent))) + ((lineNumber (s :: <str>)) :: int (! lineNumber (this))) + ((method) :: <meth-ref> (absent)) + ((sourcePath) :: <str> (or file (absent))) + ((sourcePath (s :: <str>)) :: <str> (! sourcePath (this))) + ((sourceName) :: <str> (absent)) + ((sourceName (s :: <str>)) :: <str> (! sourceName (this))) + ((declaringType) :: <ref-type> (absent)) + ((codeIndex) :: <long> -1) + ((virtualMachine) :: <vm> *the-vm*) + ((compareTo o) :: <int> + (typecase o + (<location> (- (! codeIndex (this)) (! codeIndex o)))))) + +(df absent () (primitive-throw (<absent-exc>))) + +(df all-definitions (o) + (typecase o + (<gnu.expr.ModuleMethod> (list o)) + (<gnu.expr.PrimProcedure> (list o)) + (<gnu.expr.GenericProc> (append (mappend all-definitions (gf-methods o)) + (let ((s (! get-setter o))) + (if s (all-definitions s) '())))) + (<java.lang.Class> (list o)) + (<gnu.mapping.Procedure> (all-definitions (! get-class o))) + (<kawa.lang.Macro> (list o)) + (<gnu.bytecode.ObjectType> (all-definitions (! getReflectClass o))) + (<java.lang.Object> '()) + )) + +(df gf-methods ((f <gnu.expr.GenericProc>)) + (let* ((o :: <obj-ref> (vm-mirror *the-vm* f)) + (f (! field-by-name (! reference-type o) "methods")) + (ms (vm-demirror *the-vm* (! get-value o f)))) + (filter (array-to-list ms) (fun (x) (not (nul? x)))))) + +(df src-loc (o => <location>) + (typecase o + (<gnu.expr.PrimProcedure> (src-loc (@ method o))) + (<gnu.expr.ModuleMethod> (module-method>src-loc o)) + (<gnu.expr.GenericProc> (<swank-location> #f #f)) + (<java.lang.Class> (class>src-loc o)) + (<kawa.lang.Macro> (<swank-location> #f #f)) + (<gnu.bytecode.Method> (bytemethod>src-loc o)))) + +(df module-method>src-loc ((f <gnu.expr.ModuleMethod>)) + (! location (module-method>meth-ref f))) + +(df module-method>meth-ref ((f <gnu.expr.ModuleMethod>) => <meth-ref>) + (let* ((module (! reference-type + (as <obj-ref> (vm-mirror *the-vm* (@ module f))))) + (1st-method-by-name (fun (name) + (let ((i (! methods-by-name module name))) + (cond ((! is-empty i) #f) + (#t (1st i))))))) + (as <meth-ref> (or (1st-method-by-name (! get-name f)) + (let ((mangled (mangled-name f))) + (or (1st-method-by-name mangled) + (1st-method-by-name (cat mangled "$V")) + (1st-method-by-name (cat mangled "$X")))))))) + +(df mangled-name ((f <gnu.expr.ModuleMethod>)) + (let* ((name0 (! get-name f)) + (name (cond ((nul? name0) (format "lambda~d" (@ selector f))) + (#t (!s gnu.expr.Compilation mangleName name0))))) + name)) + +(df class>src-loc ((c <java.lang.Class>) => <location>) + (let* ((type (class>ref-type c)) + (locs (! all-line-locations type))) + (cond ((not (! isEmpty locs)) (1st locs)) + (#t (<swank-location> (1st (! source-paths type "Java")) + #f))))) + +(df class>ref-type ((class <java.lang.Class>) => <ref-type>) + (! reflectedType (as <com.sun.jdi.ClassObjectReference> + (vm-mirror *the-vm* class)))) + +(df class>class-type ((class <java.lang.Class>) => <class-type>) + (as <class-type> (class>ref-type class))) + +(df bytemethod>src-loc ((m <gnu.bytecode.Method>) => <location>) + (let* ((cls (class>class-type (! get-reflect-class + (! get-declaring-class m)))) + (name (! get-name m)) + (sig (! get-signature m)) + (meth (! concrete-method-by-name cls name sig))) + (! location meth))) + +(df src-loc>elisp ((l <location>)) + (df src-loc>list ((l <location>)) + (list (ignore-errors (! source-name l "Java")) + (ignore-errors (! source-path l "Java")) + (ignore-errors (! line-number l "Java")))) + (mcase (src-loc>list l) + ((name path line) + (cond ((not path) + `(:error ,(call-with-abort (fun () (! source-path l))))) + ((! starts-with (as <str> path) "(buffer ") + (mlet (('buffer b 'offset o 'str s) (read-from-string path)) + `(:location (:buffer ,b) + (:position ,(+ o (line>offset line s))) + nil))) + (#t + `(:location ,(or (find-file-in-path name (source-path)) + (find-file-in-path path (source-path)) + (ferror "Can't find source-path: ~s ~s ~a" + path name (source-path))) + (:line ,(or line -1)) ())))))) + +(df src-loc>str ((l <location>)) + (cond ((nul? l) "<null-location>") + (#t (format "~a ~a ~a" + (or (ignore-errors (! source-path l)) + (ignore-errors (! source-name l)) + (ignore-errors (!! name declaring-type l))) + (ignore-errors (!! name method l)) + (ignore-errors (! lineNumber l)))))) + +;;;;;; class-path hacking + +;; (find-file-in-path "kawa/lib/kawa/hashtable.scm" (source-path)) + +(df find-file-in-path ((filename <str>) (path <list>)) + (let ((f (<file> filename))) + (cond ((! isAbsolute f) `(:file ,filename)) + (#t (let ((result #f)) + (find-if path (fun (dir) + (let ((x (find-file-in-dir f dir))) + (set result x))) + #f) + result))))) + +(df find-file-in-dir ((file <file>) (dir <str>)) + (let ((filename :: <str> (! getPath file))) + (or (let ((child (<file> (<file> dir) filename))) + (and (! exists child) + `(:file ,(! getPath child)))) + (try-catch + (and (not (nul? (! getEntry (<java.util.zip.ZipFile> dir) filename))) + `(:zip ,dir ,filename)) + (ex <throwable> #f))))) + +(define swank-java-source-path + (let* ((jre-home :: <str> (!s <java.lang.System> getProperty "java.home")) + (parent :: <str> (! get-parent (<file> jre-home)))) + (list (! get-path (<file> parent "src.zip"))))) + +(df source-path () + (mlet ((base) (search-path-prop "user.dir")) + (append + (list base) + (map (fun ((s <str>)) + (let ((f (<file> s)) + (base :: <str> (as <str> base))) + (cond ((! isAbsolute f) s) + (#t (! getPath (<file> base s)))))) + (class-path)) + swank-java-source-path))) + +(df class-path () + (append (search-path-prop "java.class.path") + (search-path-prop "sun.boot.class.path"))) + +(df search-path-prop ((name <str>)) + (array-to-list (! split (!s java.lang.System getProperty name) + (@s <file> pathSeparator)))) + +;;;; Disassemble + +(defslimefun disassemble-form (env form) + (mcase (read-from-string form) + (('quote name) + (let ((f (eval name env))) + (typecase f + (<gnu.expr.ModuleMethod> + (disassemble-to-string (module-method>meth-ref f)))))))) + +(df disassemble-to-string ((mr <meth-ref>) => <str>) + (with-sink #f (fun (out) (disassemble-meth-ref mr out)))) + +(df disassemble-meth-ref ((mr <meth-ref>) (out <java.io.PrintWriter>)) + (let* ((t (! declaring-type mr))) + (disas-header mr out) + (disas-code (! constant-pool t) + (! constant-pool-count t) + (! bytecodes mr) + out))) + +(df disas-header ((mr <meth-ref>) (out <java.io.PrintWriter>)) + (let* ((++ (fun ((str <str>)) (! write out str))) + (? (fun (flag str) (if flag (++ str))))) + (? (! is-static mr) "static ") + (? (! is-final mr) "final ") + (? (! is-private mr) "private ") + (? (! is-protected mr) "protected ") + (? (! is-public mr) "public ") + (++ (! name mr)) (++ (! signature mr)) (++ "\n"))) + +(df disas-code ((cpool <byte[]>) (cpoolcount <int>) (bytecode <byte[]>) + (out <java.io.PrintWriter>)) + (let* ((ct (<gnu.bytecode.ClassType> "foo")) + (met (! addMethod ct "bar" 0)) + (ca (<gnu.bytecode.CodeAttr> met)) + (constants (let* ((bs (<java.io.ByteArrayOutputStream>)) + (s (<java.io.DataOutputStream> bs))) + (! write-short s cpoolcount) + (! write s cpool) + (! flush s) + (! toByteArray bs)))) + (vm-set-slot *the-vm* ct "constants" + (<gnu.bytecode.ConstantPool> + (<java.io.DataInputStream> + (<java.io.ByteArrayInputStream> + constants)))) + (! setCode ca bytecode) + (let ((w (<gnu.bytecode.ClassTypeWriter> ct out 0))) + (! print ca w) + (! flush w)))) + +(df with-sink (sink (f <function>)) + (cond ((instance? sink <java.io.PrintWriter>) (f sink)) + ((== sink #t) (f (as <java.io.PrintWriter> (current-output-port)))) + ((== sink #f) + (let* ((buffer (<java.io.StringWriter>)) + (out (<java.io.PrintWriter> buffer))) + (f out) + (! flush out) + (! toString buffer))) + (#t (ferror "Invalid sink designator: ~s" sink)))) + +(df test-disas ((c <str>) (m <str>)) + (let* ((vm (as <vm> *the-vm*)) + (c (as <ref-type> (1st (! classes-by-name vm c)))) + (m (as <meth-ref> (1st (! methods-by-name c m))))) + (with-sink #f (fun (out) (disassemble-meth-ref m out))))) + +;; (test-disas "java.lang.Class" "toString") + + +;;;; Macroexpansion + +(defslimefun swank-expand-1 (env s) (%swank-macroexpand s env)) +(defslimefun swank-expand (env s) (%swank-macroexpand s env)) +(defslimefun swank-expand-all (env s) (%swank-macroexpand s env)) + +(df %swank-macroexpand (string env) + (pprint-to-string (%macroexpand (read-from-string string) env))) + +(df %macroexpand (sexp env) (expand sexp #:env env)) + + +;;;; Inspector + +(define-simple-class <inspector-state> () + (object #:init #!null) + (parts :: <java.util.ArrayList> #:init (<java.util.ArrayList>) ) + (stack :: <list> #:init '()) + (content :: <list> #:init '())) + +(df make-inspector (env (vm <vm>) => <chan>) + (car (spawn/chan (fun (c) (inspector c env vm))))) + +(df inspector ((c <chan>) env (vm <vm>)) + (! set-name (current-thread) "inspector") + (let ((state :: <inspector-state> (<inspector-state>)) + (open #t)) + (while open + (mcase (recv c) + (('init str id) + (set state (<inspector-state>)) + (let ((obj (try-catch (eval (read-from-string str) env) + (ex <throwable> ex)))) + (reply c (inspect-object obj state vm) id))) + (('init-mirror cc id) + (set state (<inspector-state>)) + (let* ((mirror (recv cc)) + (obj (vm-demirror vm mirror))) + (reply c (inspect-object obj state vm) id))) + (('inspect-part n id) + (let ((part (! get (@ parts state) n))) + (reply c (inspect-object part state vm) id))) + (('pop id) + (reply c (inspector-pop state vm) id)) + (('quit id) + (reply c 'nil id) + (set open #f)))))) + +(df inspect-object (obj (state <inspector-state>) (vm <vm>)) + (set (@ object state) obj) + (set (@ parts state) (<java.util.ArrayList>)) + (pushf obj (@ stack state)) + (set (@ content state) (inspector-content + `("class: " (:value ,(! getClass obj)) "\n" + ,@(inspect obj vm)) + state)) + (cond ((nul? obj) (list ':title "#!null" ':id 0 ':content `())) + (#t + (list ':title (pprint-to-string obj) + ':id (assign-index obj state) + ':content (let ((c (@ content state))) + (content-range c 0 (len c))))))) + +(df inspect (obj vm) + (let ((obj (as <obj-ref> (vm-mirror vm obj)))) + (typecase obj + (<array-ref> (inspect-array-ref vm obj)) + (<obj-ref> (inspect-obj-ref vm obj))))) + +(df inspect-array-ref ((vm <vm>) (obj <array-ref>)) + (packing (pack) + (let ((i 0)) + (for (((v :: <value>) (! getValues obj))) + (pack (format "~d: " i)) + (pack `(:value ,(vm-demirror vm v))) + (pack "\n") + (set i (1+ i)))))) + +(df inspect-obj-ref ((vm <vm>) (obj <obj-ref>)) + (let* ((type (! referenceType obj)) + (fields (! allFields type)) + (values (! getValues obj fields)) + (ifields '()) (sfields '()) (imeths '()) (smeths '()) + (frob (lambda (lists) (apply append (reverse lists))))) + (for (((f :: <field>) fields)) + (let* ((val (as <value> (! get values f))) + (l `(,(! name f) ": " (:value ,(vm-demirror vm val)) "\n"))) + (if (! is-static f) + (pushf l sfields) + (pushf l ifields)))) + (for (((m :: <meth-ref>) (! allMethods type))) + (let ((l `(,(! name m) ,(! signature m) "\n"))) + (if (! is-static m) + (pushf l smeths) + (pushf l imeths)))) + `(,@(frob ifields) + "--- static fields ---\n" ,@(frob sfields) + "--- methods ---\n" ,@(frob imeths) + "--- static methods ---\n" ,@(frob smeths)))) + +(df inspector-content (content (state <inspector-state>)) + (map (fun (part) + (mcase part + ((':value val) + `(:value ,(pprint-to-string val) ,(assign-index val state))) + (x (to-string x)))) + content)) + +(df assign-index (obj (state <inspector-state>) => <int>) + (! add (@ parts state) obj) + (1- (! size (@ parts state)))) + +(df content-range (l start end) + (let* ((len (length l)) (end (min len end))) + (list (subseq l start end) len start end))) + +(df inspector-pop ((state <inspector-state>) vm) + (cond ((<= 2 (len (@ stack state))) + (let ((obj (cadr (@ stack state)))) + (set (@ stack state) (cddr (@ stack state))) + (inspect-object obj state vm))) + (#t 'nil))) + +;;;; IO redirection + +(define-simple-class <swank-writer> (<java.io.Writer>) + (q :: <queue> #:init (<queue> (as <int> 100))) + ((*init*) (invoke-special <java.io.Writer> (this) '*init*)) + ((write (buffer :: <char[]>) (from :: <int>) (to :: <int>)) :: <void> + (synchronized (this) + (assert (not (== q #!null))) + (! put q `(write ,(<str> buffer from to))))) + ((close) :: <void> + (synchronized (this) + (! put q 'close) + (set! q #!null))) + ((flush) :: <void> + (synchronized (this) + (assert (not (== q #!null))) + (let ((ex (<exchanger>))) + (! put q `(flush ,ex)) + (! exchange ex #!null))))) + +(df swank-writer ((in <chan>) (q <queue>)) + (! set-name (current-thread) "swank-redirect-thread") + (let* ((out (as <chan> (recv in))) + (builder (<builder>)) + (flush (fun () + (unless (zero? (! length builder)) + (send out `(forward (:write-string ,(<str> builder)))) + (! setLength builder 0)))) + (closed #f)) + (while (not closed) + (mcase (! poll q (as long 200) (@s <timeunit> MILLISECONDS)) + ('#!null (flush)) + (('write s) + (! append builder (as <str> s)) + (when (> (! length builder) 4000) + (flush))) + (('flush ex) + (flush) + (! exchange (as <exchanger> ex) #!null)) + ('close + (set closed #t) + (flush)))))) + +(df make-swank-outport ((out <chan>)) + (let ((w (<swank-writer>))) + (mlet ((in . _) (spawn/chan (fun (c) (swank-writer c (@ q w))))) + (send in out)) + (<out-port> w #t #t))) + + +;;;; Monitor + +;;(define-simple-class <monitorstate> () +;; (threadmap type: (tab))) + +(df vm-monitor ((c <chan>)) + (! set-name (current-thread) "swank-vm-monitor") + (let ((vm (vm-attach))) + (log-vm-props vm) + (request-breakpoint vm) + (mlet* (((ev . _) (spawn/chan/catch + (fun (c) + (let ((q (! eventQueue vm))) + (while #t + (send c `(vm-event ,(to-list (! remove q))))))))) + (to-string (vm-to-string vm)) + (state (tab))) + (send c `(publish-vm ,vm)) + (while #t + (mcase (recv* (list c ev)) + ((_ . ('get-vm cc)) + (send cc vm)) + ((,c . ('debug-info thread from to id)) + (reply c (debug-info thread from to state) id)) + ((,c . ('throw-to-toplevel thread id)) + (set state (throw-to-toplevel thread id c state))) + ((,c . ('thread-continue thread id)) + (set state (thread-continue thread id c state))) + ((,c . ('frame-src-loc thread frame id)) + (reply c (frame-src-loc thread frame state) id)) + ((,c . ('frame-details thread frame id)) + (reply c (list (frame-locals thread frame state) '()) id)) + ((,c . ('disassemble-frame thread frame id)) + (reply c (disassemble-frame thread frame state) id)) + ((,c . ('thread-frames thread from to id)) + (reply c (thread-frames thread from to state) id)) + ((,c . ('list-threads id)) + (reply c (list-threads vm state) id)) + ((,c . ('interrupt-thread ref)) + (set state (interrupt-thread ref state c))) + ((,c . ('debug-nth-thread n)) + (let ((t (nth (get state 'all-threads #f) n))) + ;;(log "thread ~d : ~a\n" n t) + (set state (interrupt-thread t state c)))) + ((,c . ('quit-thread-browser id)) + (reply c 't id) + (set state (del state 'all-threads))) + ((,ev . ('vm-event es)) + ;;(log "vm-events: len=~a\n" (len es)) + (for (((e :: <event>) (as <list> es))) + (set state (process-vm-event e c state)))) + ((_ . ('get-exception from tid)) + (mlet ((_ _ es) (get state tid #f)) + (send from (let ((e (car es))) + (typecase e + (<exception-event> (! exception e)) + (<event> e)))))) + ((_ . ('get-local rc tid frame var)) + (send rc (frame-local-var tid frame var state))) + ))))) + +(df reply ((c <chan>) value id) + (send c `(forward (:return (:ok ,value) ,id)))) + +(df reply-abort ((c <chan>) id) + (send c `(forward (:return (:abort nil) ,id)))) + +(df process-vm-event ((e <event>) (c <chan>) state) + ;;(log "vm-event: ~s\n" e) + (typecase e + (<exception-event> + ;;(log "exception: ~s\n" (! exception e)) + ;;(log "exception-message: ~s\n" + ;; (exception-message (vm-demirror *the-vm* (! exception e)))) + ;;(log "exception-location: ~s\n" (src-loc>str (! location e))) + ;;(log "exception-catch-location: ~s\n" (src-loc>str (! catch-location e))) + (cond ((! notifyUncaught (as <com.sun.jdi.request.ExceptionRequest> + (! request e))) + (process-exception e c state)) + (#t + (let* ((t (! thread e)) + (r (! request e)) + (ex (! exception e))) + (unless (eq? *last-exception* ex) + (set *last-exception* ex) + (set *last-stacktrace* (copy-stack t))) + (! resume t)) + state))) + (<step-event> + (let* ((r (! request e)) + (k (! get-property r 'continuation))) + (! disable r) + (log "k: ~s\n" k) + (k e)) + state) + (<breakpoint-event> + (log "breakpoint event: ~a\n" e) + (debug-thread (! thread e) e state c)) + )) + +(df process-exception ((e <exception-event>) (c <chan>) state) + (let* ((tref (! thread e)) + (tid (! uniqueID tref)) + (s (get state tid #f))) + (mcase s + ('#f + ;; XXX redundant in debug-thread + (let* ((level 1) + (state (put state tid (list tref level (list e))))) + (send c `(forward (:debug ,tid ,level + ,@(debug-info tid 0 15 state)))) + (send c `(forward (:debug-activate ,tid ,level))) + state)) + ((_ level exs) + (send c `(forward (:debug-activate ,(! uniqueID tref) ,level))) + (put state tid (list tref (1+ level) (cons e exs))))))) + +(define-simple-class <faked-frame> () + (loc :: <location>) + (args) + (names) + (values :: <java.util.Map>) + (self) + ((*init* (loc :: <location>) args names (values :: <java.util.Map>) self) + (set (@ loc (this)) loc) + (set (@ args (this)) args) + (set (@ names (this)) names) + (set (@ values (this)) values) + (set (@ self (this)) self)) + ((toString) :: <str> + (format "#<ff ~a>" (src-loc>str loc)))) + +(df copy-stack ((t <thread-ref>)) + (packing (pack) + (iter (! frames t) + (fun ((f <frame>)) + (let ((vars (ignore-errors (! visibleVariables f)))) + (pack (<faked-frame> + (or (ignore-errors (! location f)) #!null) + (ignore-errors (! getArgumentValues f)) + (or vars #!null) + (or (and vars (ignore-errors (! get-values f vars))) + #!null) + (ignore-errors (! thisObject f))))))))) + +(define-simple-class <interrupt-event> (<event>) + (thread :: <thread-ref>) + ((*init* (thread :: <thread-ref>)) (set (@ thread (this)) thread)) + ((request) :: <com.sun.jdi.request.EventRequest> #!null) + ((virtualMachine) :: <vm> (! virtualMachine thread))) + +(df break (#!optional condition) + ((breakpoint condition))) + +;; We set a breakpoint on this function. It returns a function which +;; specifies what the debuggee should do next (the actual return value +;; is set via JDI). Lets hope that the compiler doesn't optimize this +;; away. +(df breakpoint (condition => <function>) + (fun () #!null)) + +;; Enable breakpoints event on the breakpoint function. +(df request-breakpoint ((vm <vm>)) + (let* ((swank-classes (! classesByName vm "swank-kawa")) + (swank-classes-legacy (! classesByName vm "swank$Mnkawa")) + (class :: <class-type> (1st (if (= (length swank-classes) 0) + swank-classes-legacy + swank-classes))) + (meth :: <meth-ref> (1st (! methodsByName class "breakpoint"))) + (erm (! eventRequestManager vm)) + (req (! createBreakpointRequest erm (! location meth)))) + (! setSuspendPolicy req (@ SUSPEND_EVENT_THREAD req)) + (! put-property req 'swank #t) + (! put-property req 'argname "condition") + (! enable req))) + +(df log-vm-props ((vm <vm>)) + (letrec-syntax ((p (syntax-rules () + ((p name) (log "~s: ~s\n" 'name (! name vm))))) + (p* (syntax-rules () + ((p* n ...) (seq (p n) ...))))) + (p* canBeModified + canRedefineClasses + canAddMethod + canUnrestrictedlyRedefineClasses + canGetBytecodes + canGetConstantPool + canGetSyntheticAttribute + canGetSourceDebugExtension + canPopFrames + canForceEarlyReturn + canGetMethodReturnValues + canGetInstanceInfo + ))) + +;;;;; Debugger + +(df debug-thread ((tref <thread-ref>) (ev <event>) state (c <chan>)) + (unless (! is-suspended tref) + (! suspend tref)) + (let* ((id (! uniqueID tref)) + (level 1) + (state (put state id (list tref level (list ev))))) + (send c `(forward (:debug ,id ,level ,@(debug-info id 0 10 state)))) + (send c `(forward (:debug-activate ,id ,level))) + state)) + +(df interrupt-thread ((tref <thread-ref>) state (c <chan>)) + (debug-thread tref (<interrupt-event> tref) state c)) + +(df debug-info ((tid <int>) (from <int>) to state) + (mlet ((thread-ref level evs) (get state tid #f)) + (let* ((tref (as <thread-ref> thread-ref)) + (vm (! virtualMachine tref)) + (ev (as <event> (car evs))) + (ex (typecase ev + (<breakpoint-event> (breakpoint-condition ev)) + (<exception-event> (! exception ev)) + (<interrupt-event> (<java.lang.Exception> "Interrupt")))) + (desc (typecase ex + (<obj-ref> + ;;(log "ex: ~a ~a\n" ex (vm-demirror vm ex)) + (! toString (vm-demirror vm ex))) + (<java.lang.Throwable> (! toString ex)))) + (type (format " [type ~a]" + (typecase ex + (<obj-ref> (! name (! referenceType ex))) + (<object> (!! getName getClass ex))))) + (bt (thread-frames tid from to state))) + `((,desc ,type nil) (("quit" "terminate current thread")) ,bt ())))) + +(df breakpoint-condition ((e <breakpoint-event>) => <obj-ref>) + (let ((frame (! frame (! thread e) 0))) + (1st (! get-argument-values frame)))) + +(df thread-frames ((tid <int>) (from <int>) to state) + (mlet ((thread level evs) (get state tid #f)) + (let* ((thread (as <thread-ref> thread)) + (fcount (! frameCount thread)) + (stacktrace (event-stacktrace (car evs))) + (missing (cond ((zero? (len stacktrace)) 0) + (#t (- (len stacktrace) fcount)))) + (fstart (max (- from missing) 0)) + (flen (max (- to from missing) 0)) + (frames (! frames thread fstart (min flen (- fcount fstart))))) + (packing (pack) + (let ((i from)) + (dotimes (_ (max (- missing from) 0)) + (pack (list i (format "~a" (stacktrace i)))) + (set i (1+ i))) + (iter frames (fun ((f <frame>)) + (let ((s (frame-to-string f))) + (pack (list i s)) + (set i (1+ i)))))))))) + +(df event-stacktrace ((ev <event>)) + (let ((nothing (fun () (<java.lang.StackTraceElement[]>))) + (vm (! virtualMachine ev))) + (typecase ev + (<breakpoint-event> + (let ((condition (vm-demirror vm (breakpoint-condition ev)))) + (cond ((instance? condition <throwable>) + (throwable-stacktrace vm condition)) + (#t (nothing))))) + (<exception-event> + (throwable-stacktrace vm (vm-demirror vm (! exception ev)))) + (<event> (nothing))))) + +(df throwable-stacktrace ((vm <vm>) (ex <throwable>)) + (cond ((== ex (ignore-errors (vm-demirror vm *last-exception*))) + *last-stacktrace*) + (#t + (! getStackTrace ex)))) + +(df frame-to-string ((f <frame>)) + (let ((loc (! location f)) + (vm (! virtualMachine f))) + (format "~a (~a)" (!! name method loc) + (call-with-abort + (fun () (format "~{~a~^ ~}" + (mapi (! getArgumentValues f) + (fun (arg) + (pprint-to-string + (vm-demirror vm arg)))))))))) + +(df frame-src-loc ((tid <int>) (n <int>) state) + (try-catch + (mlet* (((frame vm) (nth-frame tid n state)) + (vm (as <vm> vm))) + (src-loc>elisp + (typecase frame + (<frame> (! location frame)) + (<faked-frame> (@ loc frame)) + (<java.lang.StackTraceElement> + (let* ((classname (! getClassName frame)) + (classes (! classesByName vm classname)) + (t (as <ref-type> (1st classes)))) + (1st (! locationsOfLine t (! getLineNumber frame)))))))) + (ex <throwable> + (let ((msg (! getMessage ex))) + `(:error ,(if (== msg #!null) + (! toString ex) + msg)))))) + +(df nth-frame ((tid <int>) (n <int>) state) + (mlet ((tref level evs) (get state tid #f)) + (let* ((thread (as <thread-ref> tref)) + (fcount (! frameCount thread)) + (stacktrace (event-stacktrace (car evs))) + (missing (cond ((zero? (len stacktrace)) 0) + (#t (- (len stacktrace) fcount)))) + (vm (! virtualMachine thread)) + (frame (cond ((< n missing) + (stacktrace n)) + (#t (! frame thread (- n missing)))))) + (list frame vm)))) + +;;;;; Locals + +(df frame-locals ((tid <int>) (n <int>) state) + (mlet ((thread _ _) (get state tid #f)) + (let* ((thread (as <thread-ref> thread)) + (vm (! virtualMachine thread)) + (p (fun (x) (pprint-to-string + (call-with-abort (fun () (vm-demirror vm x))))))) + (map (fun (x) + (mlet ((name value) x) + (list ':name name ':value (p value) ':id 0))) + (%frame-locals tid n state))))) + +(df frame-local-var ((tid <int>) (frame <int>) (var <int>) state => <mirror>) + (cadr (nth (%frame-locals tid frame state) var))) + +(df %frame-locals ((tid <int>) (n <int>) state) + (mlet ((frame _) (nth-frame tid n state)) + (typecase frame + (<frame> + (let* ((visible (try-catch (! visibleVariables frame) + (ex <com.sun.jdi.AbsentInformationException> + '()))) + (map (! getValues frame visible)) + (p (fun (x) x))) + (packing (pack) + (let ((self (ignore-errors (! thisObject frame)))) + (when self + (pack (list "this" (p self))))) + (iter (! entrySet map) + (fun ((e <java.util.Map$Entry>)) + (let ((var (as <local-var> (! getKey e))) + (val (as <value> (! getValue e)))) + (pack (list (! name var) (p val))))))))) + (<faked-frame> + (packing (pack) + (when (@ self frame) + (pack (list "this" (@ self frame)))) + (iter (! entrySet (@ values frame)) + (fun ((e <java.util.Map$Entry>)) + (let ((var (as <local-var> (! getKey e))) + (val (as <value> (! getValue e)))) + (pack (list (! name var) val))))))) + (<java.lang.StackTraceElement> '())))) + +(df disassemble-frame ((tid <int>) (frame <int>) state) + (mlet ((frame _) (nth-frame tid frame state)) + (typecase frame + (<java.lang.StackTraceElement> "<??>") + (<frame> + (let* ((l (! location frame)) + (m (! method l)) + (c (! declaringType l))) + (disassemble-to-string m)))))) + +;;;;; Restarts + +;; FIXME: factorize +(df throw-to-toplevel ((tid <int>) (id <int>) (c <chan>) state) + (mlet ((tref level exc) (get state tid #f)) + (let* ((t (as <thread-ref> tref)) + (ev (car exc))) + (typecase ev + (<exception-event> ; actually uncaughtException + (! resume t) + (reply-abort c id) + ;;(send-debug-return c tid state) + (do ((level level (1- level)) + (exc exc (cdr exc))) + ((null? exc)) + (send c `(forward (:debug-return ,tid ,level nil)))) + (del state tid)) + (<breakpoint-event> + ;; XXX race condition? + (log "resume from from break (suspendCount: ~d)\n" (! suspendCount t)) + (let ((vm (! virtualMachine t)) + (k (fun () (primitive-throw (<listener-abort>))))) + (reply-abort c id) + (! force-early-return t (vm-mirror vm k)) + (! resume t) + (do ((level level (1- level)) + (exc exc (cdr exc))) + ((null? exc)) + (send c `(forward (:debug-return ,tid ,level nil)))) + (del state tid))) + (<interrupt-event> + (log "resume from from interrupt\n") + (let ((vm (! virtualMachine t))) + (! stop t (vm-mirror vm (<listener-abort>))) + (! resume t) + (reply-abort c id) + (do ((level level (1- level)) + (exc exc (cdr exc))) + ((null? exc)) + (send c `(forward (:debug-return ,tid ,level nil)))) + (del state tid)) + ))))) + +(df thread-continue ((tid <int>) (id <int>) (c <chan>) state) + (mlet ((tref level exc) (get state tid #f)) + (log "thread-continue: ~a ~a ~a \n" tref level exc) + (let* ((t (as <thread-ref> tref))) + (! resume t)) + (reply-abort c id) + (do ((level level (1- level)) + (exc exc (cdr exc))) + ((null? exc)) + (send c `(forward (:debug-return ,tid ,level nil)))) + (del state tid))) + +(df thread-step ((t <thread-ref>) k) + (let* ((vm (! virtual-machine t)) + (erm (! eventRequestManager vm)) + (<sr> <com.sun.jdi.request.StepRequest>) + (req (! createStepRequest erm t + (@s <sr> STEP_MIN) + (@s <sr> STEP_OVER)))) + (! setSuspendPolicy req (@ SUSPEND_EVENT_THREAD req)) + (! addCountFilter req 1) + (! put-property req 'continuation k) + (! enable req))) + +(df eval-in-thread ((t <thread-ref>) sexp + #!optional (env :: <env> (!s <env> current))) + (let* ((vm (! virtualMachine t)) + (sc :: <class-type> + (1st (! classes-by-name vm "kawa.standard.Scheme"))) + (ev :: <meth-ref> + (1st (! methods-by-name sc "eval" + (cat "(Ljava/lang/Object;Lgnu/mapping/Environment;)" + "Ljava/lang/Object;"))))) + (! invokeMethod sc t ev (list sexp env) + (@s <class-type> INVOKE_SINGLE_THREADED)))) + +;;;;; Threads + +(df list-threads (vm :: <vm> state) + (let* ((threads (! allThreads vm))) + (put state 'all-threads threads) + (packing (pack) + (pack '(\:id \:name \:status \:priority)) + (iter threads (fun ((t <thread-ref>)) + (pack (list (! uniqueID t) + (! name t) + (let ((s (thread-status t))) + (if (! is-suspended t) + (cat "SUSPENDED/" s) + s)) + 0))))))) + +(df thread-status (t :: <thread-ref>) + (let ((s (! status t))) + (cond ((= s (@s <thread-ref> THREAD_STATUS_UNKNOWN)) "UNKNOWN") + ((= s (@s <thread-ref> THREAD_STATUS_ZOMBIE)) "ZOMBIE") + ((= s (@s <thread-ref> THREAD_STATUS_RUNNING)) "RUNNING") + ((= s (@s <thread-ref> THREAD_STATUS_SLEEPING)) "SLEEPING") + ((= s (@s <thread-ref> THREAD_STATUS_MONITOR)) "MONITOR") + ((= s (@s <thread-ref> THREAD_STATUS_WAIT)) "WAIT") + ((= s (@s <thread-ref> THREAD_STATUS_NOT_STARTED)) "NOT_STARTED") + (#t "<bug>")))) + +;;;;; Bootstrap + +(df vm-attach (=> <vm>) + (attach (getpid) 20)) + +(df attach (pid timeout) + (log "attaching: ~a ~a\n" pid timeout) + (let* ((<ac> <com.sun.jdi.connect.AttachingConnector>) + (<arg> <com.sun.jdi.connect.Connector$Argument>) + (vmm (!s com.sun.jdi.Bootstrap virtualMachineManager)) + (pa (as <ac> + (or + (find-if (! attaching-connectors vmm) + (fun (x :: <ac>) + (! equals (! name x) "com.sun.jdi.ProcessAttach")) + #f) + (error "ProcessAttach connector not found")))) + (args (! default-arguments pa))) + (! set-value (as <arg> (! get args (to-str "pid"))) pid) + (when timeout + (! set-value (as <arg> (! get args (to-str "timeout"))) timeout)) + (log "attaching2: ~a ~a\n" pa args) + (! attach pa args))) + +(df getpid () + (let ((p (make-process (command-parse "echo $PPID") #!null))) + (! waitFor p) + (! read-line (<java.io.BufferedReader> (<in> (! get-input-stream p)))))) + +(df request-uncaught-exception-events ((vm <vm>)) + (let* ((erm (! eventRequestManager vm)) + (req (! createExceptionRequest erm #!null #f #t))) + (! setSuspendPolicy req (@ SUSPEND_EVENT_THREAD req)) + (! addThreadFilter req (vm-mirror vm (current-thread))) + (! enable req))) + + +(df request-caught-exception-events ((vm <vm>)) + (let* ((erm (! eventRequestManager vm)) + (req (! createExceptionRequest erm #!null #t #f))) + (! setSuspendPolicy req (@ SUSPEND_EVENT_THREAD req)) + (! addThreadFilter req (vm-mirror vm (current-thread))) + (! addClassExclusionFilter req "java.lang.ClassLoader") + (! addClassExclusionFilter req "java.net.URLClassLoader") + (! addClassExclusionFilter req "java.net.URLClassLoader$1") + (! enable req))) + +(df set-stacktrace-recording ((vm <vm>) (flag <boolean>)) + (for (((e :: <com.sun.jdi.request.ExceptionRequest>) + (!! exceptionRequests eventRequestManager vm))) + (when (! notify-caught e) + (! setEnabled e flag)))) + +;; (set-stacktrace-recording *the-vm* #f) + +(df vm-to-string ((vm <vm>)) + (let* ((obj (as <ref-type> (1st (! classesByName vm "java.lang.Object")))) + (met (as <meth-ref> (1st (! methodsByName obj "toString"))))) + (fun ((o <obj-ref>) (t <thread-ref>)) + (! value + (as <str-ref> + (! invokeMethod o t met '() + (@s <obj-ref> INVOKE_SINGLE_THREADED))))))) + +(define-simple-class <swank-global-variable> () + (var #:allocation 'static)) + +(define-variable *global-get-mirror* #!null) +(define-variable *global-set-mirror* #!null) +(define-variable *global-get-raw* #!null) +(define-variable *global-set-raw* #!null) + +(df init-global-field ((vm <vm>)) + (when (nul? *global-get-mirror*) + (set (@s <swank-global-variable> var) #!null) ; prepare class + (let* ((swank-global-variable-classes + (! classes-by-name vm "swank-global-variable")) + (swank-global-variable-classes-legacy + (! classes-by-name vm "swank$Mnglobal$Mnvariable")) + (c (as <com.sun.jdi.ClassType> + (1st (if (= (length swank-global-variable-classes) 0) + swank-global-variable-classes-legacy + swank-global-variable-classes)))) + (f (! fieldByName c "var"))) + (set *global-get-mirror* (fun () (! getValue c f))) + (set *global-set-mirror* (fun ((v <obj-ref>)) (! setValue c f v)))) + (set *global-get-raw* (fun () '() (@s <swank-global-variable> var))) + (set *global-set-raw* (fun (x) + (set (@s <swank-global-variable> var) x))))) + +(df vm-mirror ((vm <vm>) obj) + (synchronized vm + (init-global-field vm) + (*global-set-raw* obj) + (*global-get-mirror*))) + +(df vm-demirror ((vm <vm>) (v <value>)) + (synchronized vm + (if (== v #!null) + #!null + (typecase v + (<obj-ref> (init-global-field vm) + (*global-set-mirror* v) + (*global-get-raw*)) + (<com.sun.jdi.IntegerValue> (! value v)) + (<com.sun.jdi.LongValue> (! value v)) + (<com.sun.jdi.CharValue> (! value v)) + (<com.sun.jdi.ByteValue> (! value v)) + (<com.sun.jdi.BooleanValue> (! value v)) + (<com.sun.jdi.ShortValue> (! value v)) + (<com.sun.jdi.FloatValue> (! value v)) + (<com.sun.jdi.DoubleValue> (! value v)))))) + +(df vm-set-slot ((vm <vm>) (o <object>) (name <str>) value) + (let* ((o (as <obj-ref> (vm-mirror vm o))) + (t (! reference-type o)) + (f (! field-by-name t name))) + (! set-value o f (vm-mirror vm value)))) + +(define-simple-class <ucex-handler> + (<java.lang.Thread$UncaughtExceptionHandler>) + (f :: <gnu.mapping.Procedure>) + ((*init* (f :: <gnu.mapping.Procedure>)) (set (@ f (this)) f)) + ((uncaughtException (t :: <thread>) (e :: <throwable>)) + :: <void> + (! println (@s java.lang.System err) (to-str "uhexc:::")) + (! apply2 f t e) + #!void)) + +;;;; Channels + +(df spawn (f) + (let ((thread (<thread> (%%runnable f)))) + (! start thread) + thread)) + + +;; gnu.mapping.RunnableClosure uses the try{...}catch(Throwable){...} +;; idiom which defeats all attempts to use a break-on-error-style +;; debugger. Previously I had my own version of RunnableClosure +;; without that deficiency but something in upstream changed and it no +;; longer worked. Now we use the normal RunnableClosure and at the +;; cost of taking stack snapshots on every throw. +(df %%runnable (f => <java.lang.Runnable>) + ;;(<runnable> f) + ;;(<gnu.mapping.RunnableClosure> f) + ;;(runnable f) + (%runnable f) + ) + +(df %runnable (f => <java.lang.Runnable>) + (runnable + (fun () + (try-catch (f) + (ex <throwable> + (log "exception in thread ~s: ~s" (current-thread) + ex) + (! printStackTrace ex)))))) + +(df chan () + (let ((lock (<object>)) + (im (<chan>)) + (ex (<chan>))) + (set (@ lock im) lock) + (set (@ lock ex) lock) + (set (@ peer im) ex) + (set (@ peer ex) im) + (cons im ex))) + +(df immutable? (obj) + (or (== obj #!null) + (symbol? obj) + (number? obj) + (char? obj) + (instance? obj <str>) + (null? obj))) + +(df send ((c <chan>) value => <void>) + (df pass (obj) + (cond ((immutable? obj) obj) + ((string? obj) (! to-string obj)) + ((pair? obj) + (let loop ((r (list (pass (car obj)))) + (o (cdr obj))) + (cond ((null? o) (reverse! r)) + ((pair? o) (loop (cons (pass (car o)) r) (cdr o))) + (#t (append (reverse! r) (pass o)))))) + ((instance? obj <chan>) + (let ((o :: <chan> obj)) + (assert (== (@ owner o) (current-thread))) + (synchronized (@ lock c) + (set (@ owner o) (@ owner (@ peer c)))) + o)) + ((or (instance? obj <env>) + (instance? obj <mirror>)) + ;; those can be shared, for pragmatic reasons + obj + ) + (#t (error "can't send" obj (class-name-sans-package obj))))) + ;;(log "send: ~s ~s -> ~s\n" value (@ owner c) (@ owner (@ peer c))) + (assert (== (@ owner c) (current-thread))) + ;;(log "lock: ~s send\n" (@ owner (@ peer c))) + (synchronized (@ owner (@ peer c)) + (! put (@ queue (@ peer c)) (pass value)) + (! notify (@ owner (@ peer c)))) + ;;(log "unlock: ~s send\n" (@ owner (@ peer c))) + ) + +(df recv ((c <chan>)) + (cdr (recv/timeout (list c) 0))) + +(df recv* ((cs <iterable>)) + (recv/timeout cs 0)) + +(df recv/timeout ((cs <iterable>) (timeout <long>)) + (let ((self (current-thread)) + (end (if (zero? timeout) + 0 + (+ (current-time) timeout)))) + ;;(log "lock: ~s recv\n" self) + (synchronized self + (let loop () + ;;(log "receive-loop: ~s\n" self) + (let ((ready (find-if cs + (fun ((c <chan>)) + (not (! is-empty (@ queue c)))) + #f))) + (cond (ready + ;;(log "unlock: ~s recv\n" self) + (cons ready (! take (@ queue (as <chan> ready))))) + ((zero? timeout) + ;;(log "wait: ~s recv\n" self) + (! wait self) (loop)) + (#t + (let ((now (current-time))) + (cond ((<= end now) + 'timeout) + (#t + ;;(log "wait: ~s recv\n" self) + (! wait self (- end now)) + (loop))))))))))) + +(df rpc ((c <chan>) msg) + (mlet* (((im . ex) (chan)) + ((op . args) msg)) + (send c `(,op ,ex . ,args)) + (recv im))) + +(df spawn/chan (f) + (mlet ((im . ex) (chan)) + (let ((thread (<thread> (%%runnable (fun () (f ex)))))) + (set (@ owner ex) thread) + (! start thread) + (cons im thread)))) + +(df spawn/chan/catch (f) + (spawn/chan + (fun (c) + (try-catch + (f c) + (ex <throwable> + (send c `(error ,(! toString ex) + ,(class-name-sans-package ex) + ,(map (fun (e) (! to-string e)) + (array-to-list (! get-stack-trace ex)))))))))) + +;;;; Logging + +(define swank-log-port (current-error-port)) +(df log (fstr #!rest args) + (synchronized swank-log-port + (apply format swank-log-port fstr args) + (force-output swank-log-port)) + #!void) + +;;;; Random helpers + +(df 1+ (x) (+ x 1)) +(df 1- (x) (- x 1)) + +(df len (x => <int>) + (typecase x + (<list> (length x)) + (<str> (! length x)) + (<string> (string-length x)) + (<vector> (vector-length x)) + (<java.util.List> (! size x)) + (<object[]> (@ length x)))) + +;;(df put (tab key value) (hash-table-set! tab key value) tab) +;;(df get (tab key default) (hash-table-ref/default tab key default)) +;;(df del (tab key) (hash-table-delete! tab key) tab) +;;(df tab () (make-hash-table)) + +(df put (tab key value) (hashtable-set! tab key value) tab) +(df get (tab key default) (hashtable-ref tab key default)) +(df del (tab key) (hashtable-delete! tab key) tab) +(df tab () (make-eqv-hashtable)) + +(df equal (x y => <boolean>) (equal? x y)) + +(df current-thread (=> <thread>) (!s java.lang.Thread currentThread)) +(df current-time (=> <long>) (!s java.lang.System currentTimeMillis)) + +(df nul? (x) (== x #!null)) + +(df read-from-string (str) + (call-with-input-string str read)) + +;;(df print-to-string (obj) (call-with-output-string (fun (p) (write obj p)))) + +(df pprint-to-string (obj) + (let* ((w (<java.io.StringWriter>)) + (p (<out-port> w #t #f))) + (try-catch (print-object obj p) + (ex <throwable> + (format p "#<error while printing ~a ~a>" + ex (class-name-sans-package ex)))) + (! flush p) + (to-string (! getBuffer w)))) + +(df print-object (obj stream) + (typecase obj + #; + ((or (eql #!null) (eql #!eof) + <list> <number> <character> <string> <vector> <procedure> <boolean>) + (write obj stream)) + (#t + #;(print-unreadable-object obj stream) + (write obj stream) + ))) + +(df print-unreadable-object ((o <object>) stream) + (let* ((string (! to-string o)) + (class (! get-class o)) + (name (! get-name class)) + (simplename (! get-simple-name class))) + (cond ((! starts-with string "#<") + (format stream "~a" string)) + ((or (! starts-with string name) + (! starts-with string simplename)) + (format stream "#<~a>" string)) + (#t + (format stream "#<~a ~a>" name string))))) + +(define cat string-append) + +(df values-to-list (values) + (typecase values + (<gnu.mapping.Values> (array-to-list (! getValues values))) + (<object> (list values)))) + +;; (to-list (as-list (values 1 2 2))) + +(df array-to-list ((array <object[]>) => <list>) + (packing (pack) + (dotimes (i (@ length array)) + (pack (array i))))) + +(df lisp-bool (obj) + (cond ((== obj 'nil) #f) + ((== obj 't) #t) + (#t (error "Can't map lisp boolean" obj)))) + +(df path-sans-extension ((p path) => <string>) + (let ((ex (! get-extension p)) + (str (! to-string p))) + (to-string (cond ((not ex) str) + (#t (! substring str 0 (- (len str) (len ex) 1))))))) + +(df class-name-sans-package ((obj <object>)) + (cond ((nul? obj) "<#!null>") + (#t + (try-catch + (let* ((c (! get-class obj)) + (n (! get-simple-name c))) + (cond ((equal n "") (! get-name c)) + (#t n))) + (e <java.lang.Throwable> + (format "#<~a: ~a>" e (! get-message e))))))) + +(df list-env (#!optional (env :: <env> (!s <env> current))) + (let ((enum (! enumerateAllLocations env))) + (packing (pack) + (while (! hasMoreElements enum) + (pack (! nextLocation enum)))))) + +(df list-file (filename) + (with (port (call-with-input-file filename)) + (let* ((lang (!s gnu.expr.Language getDefaultLanguage)) + (messages (<gnu.text.SourceMessages>)) + (comp (! parse lang (as <in-port> port) messages 0))) + (! get-module comp)))) + +(df list-decls (file) + (let* ((module (as <gnu.expr.ModuleExp> (list-file file)))) + (do ((decl :: <gnu.expr.Declaration> + (! firstDecl module) (! nextDecl decl))) + ((nul? decl)) + (format #t "~a ~a:~d:~d\n" decl + (! getFileName decl) + (! getLineNumber decl) + (! getColumnNumber decl) + )))) + +(df %time (f) + (define-alias <mf> <java.lang.management.ManagementFactory>) + (define-alias <gc> <java.lang.management.GarbageCollectorMXBean>) + (let* ((gcs (!s <mf> getGarbageCollectorMXBeans)) + (mem (!s <mf> getMemoryMXBean)) + (jit (!s <mf> getCompilationMXBean)) + (oldjit (! getTotalCompilationTime jit)) + (oldgc (packing (pack) + (iter gcs (fun ((gc <gc>)) + (pack (cons gc + (list (! getCollectionCount gc) + (! getCollectionTime gc)))))))) + (heap (!! getUsed getHeapMemoryUsage mem)) + (nonheap (!! getUsed getNonHeapMemoryUsage mem)) + (start (!s java.lang.System nanoTime)) + (values (f)) + (end (!s java.lang.System nanoTime)) + (newheap (!! getUsed getHeapMemoryUsage mem)) + (newnonheap (!! getUsed getNonHeapMemoryUsage mem))) + (format #t "~&") + (let ((njit (! getTotalCompilationTime jit))) + (format #t "; JIT compilation: ~:d ms (~:d)\n" (- njit oldjit) njit)) + (iter gcs (fun ((gc <gc>)) + (mlet ((_ count time) (assoc gc oldgc)) + (format #t "; GC ~a: ~:d ms (~d)\n" + (! getName gc) + (- (! getCollectionTime gc) time) + (- (! getCollectionCount gc) count))))) + (format #t "; Heap: ~@:d (~:d)\n" (- newheap heap) newheap) + (format #t "; Non-Heap: ~@:d (~:d)\n" (- newnonheap nonheap) newnonheap) + (format #t "; Elapsed time: ~:d us\n" (/ (- end start) 1000)) + values)) + +(define-syntax time + (syntax-rules () + ((time form) + (%time (lambda () form))))) + +(df gc () + (let* ((mem (!s java.lang.management.ManagementFactory getMemoryMXBean)) + (oheap (!! getUsed getHeapMemoryUsage mem)) + (onheap (!! getUsed getNonHeapMemoryUsage mem)) + (_ (! gc mem)) + (heap (!! getUsed getHeapMemoryUsage mem)) + (nheap (!! getUsed getNonHeapMemoryUsage mem))) + (format #t "; heap: ~@:d (~:d) non-heap: ~@:d (~:d)\n" + (- heap oheap) heap (- onheap nheap) nheap))) + +(df room () + (let* ((pools (!s java.lang.management.ManagementFactory + getMemoryPoolMXBeans)) + (mem (!s java.lang.management.ManagementFactory getMemoryMXBean)) + (heap (!! getUsed getHeapMemoryUsage mem)) + (nheap (!! getUsed getNonHeapMemoryUsage mem))) + (iter pools (fun ((p <java.lang.management.MemoryPoolMXBean>)) + (format #t "~&; ~a~1,16t: ~10:d\n" + (! getName p) + (!! getUsed getUsage p)))) + (format #t "; Heap~1,16t: ~10:d\n" heap) + (format #t "; Non-Heap~1,16t: ~10:d\n" nheap))) + +;; (df javap (class #!key method signature) +;; (let* ((<is> <java.io.ByteArrayInputStream>) +;; (bytes +;; (typecase class +;; (<string> (read-bytes (<java.io.FileInputStream> (to-str class)))) +;; (<byte[]> class) +;; (<symbol> (read-class-file class)))) +;; (cdata (<sun.tools.javap.ClassData> (<is> bytes))) +;; (p (<sun.tools.javap.JavapPrinter> +;; (<is> bytes) +;; (current-output-port) +;; (<sun.tools.javap.JavapEnvironment>)))) +;; (cond (method +;; (dolist ((m <sun.tools.javap.MethodData>) +;; (array-to-list (! getMethods cdata))) +;; (when (and (equal (to-str method) (! getName m)) +;; (or (not signature) +;; (equal signature (! getInternalSig m)))) +;; (! printMethodSignature p m (! getAccess m)) +;; (! printExceptions p m) +;; (newline) +;; (! printVerboseHeader p m) +;; (! printcodeSequence p m)))) +;; (#t (p:print))) +;; (values))) + +(df read-bytes ((is <java.io.InputStream>) => <byte[]>) + (let ((os (<java.io.ByteArrayOutputStream>))) + (let loop () + (let ((c (! read is))) + (cond ((= c -1)) + (#t (! write os c) (loop))))) + (! to-byte-array os))) + +(df read-class-file ((name <symbol>) => <byte[]>) + (let ((f (cat (! replace (to-str name) (as <char> #\.) (as <char> #\/)) + ".class"))) + (mcase (find-file-in-path f (class-path)) + ('#f (ferror "Can't find classfile for ~s" name)) + ((:zip zipfile entry) + (let* ((z (<java.util.zip.ZipFile> (as <str> zipfile))) + (e (! getEntry z (as <str> entry)))) + (read-bytes (! getInputStream z e)))) + ((:file s) (read-bytes (<java.io.FileInputStream> (as <str> s))))))) + +(df all-instances ((vm <vm>) (classname <str>)) + (mappend (fun ((c <class-type>)) (to-list (! instances c (as long 9999)))) + (%all-subclasses vm classname))) + +(df %all-subclasses ((vm <vm>) (classname <str>)) + (mappend (fun ((c <class-type>)) (cons c (to-list (! subclasses c)))) + (to-list (! classes-by-name vm classname)))) + +(df with-output-to-string (thunk => <str>) + (call-with-output-string + (fun (s) (parameterize ((current-output-port s)) (thunk))))) + +(df find-if ((i <iterable>) test default) + (let ((iter (! iterator i)) + (found #f)) + (while (and (not found) (! has-next iter)) + (let ((e (! next iter))) + (when (test e) + (set found #t) + (set default e)))) + default)) + +(df filter ((i <iterable>) test => <list>) + (packing (pack) + (for ((e i)) + (when (test e) + (pack e))))) + +(df iter ((i <iterable>) f) + (for ((e i)) (f e))) + +(df mapi ((i <iterable>) f => <list>) + (packing (pack) (for ((e i)) (pack (f e))))) + +(df nth ((i <iterable>) (n <int>)) + (let ((iter (! iterator i))) + (dotimes (i n) + (! next iter)) + (! next iter))) + +(df 1st ((i <iterable>)) (!! next iterator i)) + +(df to-list ((i <iterable>) => <list>) + (packing (pack) (for ((e i)) (pack e)))) + +(df as-list ((o <java.lang.Object[]>) => <java.util.List>) + (!s java.util.Arrays asList o)) + +(df mappend (f list) + (apply append (map f list))) + +(df subseq (s from to) + (typecase s + (<list> (apply list (! sub-list s from to))) + (<vector> (apply vector (! sub-list s from to))) + (<str> (! substring s from to)) + (<byte[]> (let* ((len (as <int> (- to from))) + (t (<byte[]> #:length len))) + (!s java.lang.System arraycopy s from t 0 len) + t)))) + +(df to-string (obj => <string>) + (typecase obj + (<str> (<gnu.lists.FString> obj)) + ((satisfies string?) obj) + ((satisfies symbol?) (symbol->string obj)) + (<java.lang.StringBuffer> (<gnu.lists.FString> obj)) + (<java.lang.StringBuilder> (<gnu.lists.FString> obj)) + (#t (error "Not a string designator" obj + (class-name-sans-package obj))))) + +(df to-str (obj => <str>) + (cond ((instance? obj <str>) obj) + ((string? obj) (! toString obj)) + ((symbol? obj) (! getName (as <gnu.mapping.Symbol> obj))) + (#t (error "Not a string designator" obj + (class-name-sans-package obj))))) + +)) + +;; Local Variables: +;; mode: goo +;; compile-command: "\ +;; rm -rf classes && \ +;; JAVA_OPTS=-Xss2M kawa --r7rs -d classes -C swank-kawa.scm && \ +;; jar cf swank-kawa.jar -C classes ." +;; End: diff --git a/vim/bundle/slimv/slime/contrib/swank-larceny.scm b/vim/bundle/slimv/slime/contrib/swank-larceny.scm new file mode 100644 index 0000000..e4d730d --- /dev/null +++ b/vim/bundle/slimv/slime/contrib/swank-larceny.scm @@ -0,0 +1,176 @@ +;; swank-larceny.scm --- Swank server for Larceny +;; +;; License: Public Domain +;; Author: Helmut Eller +;; +;; In a shell execute: +;; larceny -r6rs -program swank-larceny.scm +;; and then `M-x slime-connect' in Emacs. + +(library (swank os) + (export getpid make-server-socket accept local-port close-socket) + (import (rnrs) + (primitives foreign-procedure + ffi/handle->address + ffi/string->asciiz + sizeof:pointer + sizeof:int + %set-pointer + %get-int)) + + (define getpid (foreign-procedure "getpid" '() 'int)) + (define fork (foreign-procedure "fork" '() 'int)) + (define close (foreign-procedure "close" '(int) 'int)) + (define dup2 (foreign-procedure "dup2" '(int int) 'int)) + + (define bytevector-content-offset$ sizeof:pointer) + + (define execvp% (foreign-procedure "execvp" '(string boxed) 'int)) + (define (execvp file . args) + (let* ((nargs (length args)) + (argv (make-bytevector (* (+ nargs 1) + sizeof:pointer)))) + (do ((offset 0 (+ offset sizeof:pointer)) + (as args (cdr as))) + ((null? as)) + (%set-pointer argv + offset + (+ (ffi/handle->address (ffi/string->asciiz (car as))) + bytevector-content-offset$))) + (%set-pointer argv (* nargs sizeof:pointer) 0) + (execvp% file argv))) + + (define pipe% (foreign-procedure "pipe" '(boxed) 'int)) + (define (pipe) + (let ((array (make-bytevector (* sizeof:int 2)))) + (let ((r (pipe% array))) + (values r (%get-int array 0) (%get-int array sizeof:int))))) + + (define (fork/exec file . args) + (let ((pid (fork))) + (cond ((= pid 0) + (apply execvp file args)) + (#t pid)))) + + (define (start-process file . args) + (let-values (((r1 down-out down-in) (pipe)) + ((r2 up-out up-in) (pipe)) + ((r3 err-out err-in) (pipe))) + (assert (= 0 r1)) + (assert (= 0 r2)) + (assert (= 0 r3)) + (let ((pid (fork))) + (case pid + ((-1) + (error "Failed to fork a subprocess.")) + ((0) + (close up-out) + (close err-out) + (close down-in) + (dup2 down-out 0) + (dup2 up-in 1) + (dup2 err-in 2) + (apply execvp file args) + (exit 1)) + (else + (close down-out) + (close up-in) + (close err-in) + (list pid + (make-fd-io-stream up-out down-in) + (make-fd-io-stream err-out err-out))))))) + + (define (make-fd-io-stream in out) + (let ((write (lambda (bv start count) (fd-write out bv start count))) + (read (lambda (bv start count) (fd-read in bv start count))) + (closeit (lambda () (close in) (close out)))) + (make-custom-binary-input/output-port + "fd-stream" read write #f #f closeit))) + + (define write% (foreign-procedure "write" '(int ulong int) 'int)) + (define (fd-write fd bytevector start count) + (write% fd + (+ (ffi/handle->address bytevector) + bytevector-content-offset$ + start) + count)) + + (define read% (foreign-procedure "read" '(int ulong int) 'int)) + (define (fd-read fd bytevector start count) + ;;(printf "fd-read: ~a ~s ~a ~a\n" fd bytevector start count) + (read% fd + (+ (ffi/handle->address bytevector) + bytevector-content-offset$ + start) + count)) + + (define (make-server-socket port) + (let* ((args `("/bin/bash" "bash" + "-c" + ,(string-append + "netcat -s 127.0.0.1 -q 0 -l -v " + (if port + (string-append "-p " (number->string port)) + "")))) + (nc (apply start-process args)) + (err (transcoded-port (list-ref nc 2) + (make-transcoder (latin-1-codec)))) + (line (get-line err)) + (pos (last-index-of line '#\]))) + (cond (pos + (let* ((tail (substring line (+ pos 1) (string-length line))) + (port (get-datum (open-string-input-port tail)))) + (list (car nc) (cadr nc) err port))) + (#t (error "netcat failed: " line))))) + + (define (accept socket codec) + (let* ((line (get-line (caddr socket))) + (pos (last-index-of line #\]))) + (cond (pos + (close-port (caddr socket)) + (let ((stream (cadr socket))) + (let ((io (transcoded-port stream (make-transcoder codec)))) + (values io io)))) + (else (error "accept failed: " line))))) + + (define (local-port socket) + (list-ref socket 3)) + + (define (last-index-of str chr) + (let loop ((i (string-length str))) + (cond ((<= i 0) #f) + (#t (let ((i (- i 1))) + (cond ((char=? (string-ref str i) chr) + i) + (#t + (loop i)))))))) + + (define (close-socket socket) + ;;(close-port (cadr socket)) + #f + ) + + ) + +(library (swank sys) + (export implementation-name eval-in-interaction-environment) + (import (rnrs) + (primitives system-features + aeryn-evaluator)) + + (define (implementation-name) "larceny") + + ;; see $LARCENY/r6rsmode.sch: + ;; Larceny's ERR5RS and R6RS modes. + ;; Code names: + ;; Aeryn ERR5RS + ;; D'Argo R6RS-compatible + ;; Spanky R6RS-conforming (not yet implemented) + (define (eval-in-interaction-environment form) + (aeryn-evaluator form)) + + ) + +(import (rnrs) (rnrs eval) (larceny load)) +(load "swank-r6rs.scm") +(eval '(start-server #f) (environment '(swank))) diff --git a/vim/bundle/slimv/slime/contrib/swank-listener-hooks.lisp b/vim/bundle/slimv/slime/contrib/swank-listener-hooks.lisp new file mode 100644 index 0000000..f289c90 --- /dev/null +++ b/vim/bundle/slimv/slime/contrib/swank-listener-hooks.lisp @@ -0,0 +1,91 @@ +;;; swank-listener-hooks.lisp --- listener with special hooks +;; +;; Author: Alan Ruttenberg <alanr-l@mumble.net> + +;; Provides *slime-repl-eval-hooks* special variable which +;; can be used for easy interception of SLIME REPL form evaluation +;; for purposes such as integration with application event loop. + +(in-package :swank) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (swank-require :swank-repl)) + +(defvar *slime-repl-advance-history* nil + "In the dynamic scope of a single form typed at the repl, is set to nil to + prevent the repl from advancing the history - * ** *** etc.") + +(defvar *slime-repl-suppress-output* nil + "In the dynamic scope of a single form typed at the repl, is set to nil to + prevent the repl from printing the result of the evalation.") + +(defvar *slime-repl-eval-hook-pass* (gensym "PASS") + "Token to indicate that a repl hook declines to evaluate the form") + +(defvar *slime-repl-eval-hooks* nil + "A list of functions. When the repl is about to eval a form, first try running each of + these hooks. The first hook which returns a value which is not *slime-repl-eval-hook-pass* + is considered a replacement for calling eval. If there are no hooks, or all + pass, then eval is used.") + +(export '*slime-repl-eval-hooks*) + +(defslimefun repl-eval-hook-pass () + "call when repl hook declines to evaluate the form" + (throw *slime-repl-eval-hook-pass* *slime-repl-eval-hook-pass*)) + +(defslimefun repl-suppress-output () + "In the dynamic scope of a single form typed at the repl, call to + prevent the repl from printing the result of the evalation." + (setq *slime-repl-suppress-output* t)) + +(defslimefun repl-suppress-advance-history () + "In the dynamic scope of a single form typed at the repl, call to + prevent the repl from advancing the history - * ** *** etc." + (setq *slime-repl-advance-history* nil)) + +(defun %eval-region (string) + (with-input-from-string (stream string) + (let (- values) + (loop + (let ((form (read stream nil stream))) + (when (eq form stream) + (fresh-line) + (finish-output) + (return (values values -))) + (setq - form) + (if *slime-repl-eval-hooks* + (setq values (run-repl-eval-hooks form)) + (setq values (multiple-value-list (eval form)))) + (finish-output)))))) + +(defun run-repl-eval-hooks (form) + (loop for hook in *slime-repl-eval-hooks* + for res = (catch *slime-repl-eval-hook-pass* + (multiple-value-list (funcall hook form))) + until (not (eq res *slime-repl-eval-hook-pass*)) + finally (return + (if (eq res *slime-repl-eval-hook-pass*) + (multiple-value-list (eval form)) + res)))) + +(defun %listener-eval (string) + (clear-user-input) + (with-buffer-syntax () + (swank-repl::track-package + (lambda () + (let ((*slime-repl-suppress-output* :unset) + (*slime-repl-advance-history* :unset)) + (multiple-value-bind (values last-form) (%eval-region string) + (unless (or (and (eq values nil) (eq last-form nil)) + (eq *slime-repl-advance-history* nil)) + (setq *** ** ** * * (car values) + /// // // / / values)) + (setq +++ ++ ++ + + last-form) + (unless (eq *slime-repl-suppress-output* t) + (funcall swank-repl::*send-repl-results-function* values))))))) + nil) + +(setq swank-repl::*listener-eval-function* '%listener-eval) + +(provide :swank-listener-hooks) diff --git a/vim/bundle/slimv/slime/contrib/swank-macrostep.lisp b/vim/bundle/slimv/slime/contrib/swank-macrostep.lisp new file mode 100644 index 0000000..77dfa3f --- /dev/null +++ b/vim/bundle/slimv/slime/contrib/swank-macrostep.lisp @@ -0,0 +1,227 @@ +;;; swank-macrostep.lisp -- fancy macro-expansion via macrostep.el +;; +;; Authors: LuÃs Oliveira <luismbo@gmail.com> +;; Jon Oddie <j.j.oddie@gmail.com> +;; +;; License: Public Domain + +(defpackage swank-macrostep + (:use cl swank) + (:import-from swank + #:*macroexpand-printer-bindings* + #:with-buffer-syntax + #:with-bindings + #:to-string + #:macroexpand-all + #:compiler-macroexpand-1 + #:defslimefun + #:collect-macro-forms) + (:export #:macrostep-expand-1 + #:macro-form-p)) + +(in-package #:swank-macrostep) + +(defslimefun macrostep-expand-1 (string compiler-macros? context) + (with-buffer-syntax () + (let ((form (read-from-string string))) + (multiple-value-bind (expansion error-message) + (expand-form-once form compiler-macros? context) + (if error-message + `(:error ,error-message) + (multiple-value-bind (macros compiler-macros) + (collect-macro-forms-in-context expansion context) + (let* ((all-macros (append macros compiler-macros)) + (pretty-expansion (pprint-to-string expansion)) + (positions (collect-form-positions expansion + pretty-expansion + all-macros)) + (subform-info + (loop + for form in all-macros + for (start end) in positions + when (and start end) + collect (let ((op-name (to-string (first form))) + (op-type + (if (member form macros) + :macro + :compiler-macro))) + (list op-name + op-type + start))))) + `(:ok ,pretty-expansion ,subform-info)))))))) + +(defun expand-form-once (form compiler-macros? context) + (multiple-value-bind (expansion expanded?) + (macroexpand-1-in-context form context) + (if expanded? + (values expansion nil) + (if (not compiler-macros?) + (values nil "Not a macro form") + (multiple-value-bind (expansion expanded?) + (compiler-macroexpand-1 form) + (if expanded? + (values expansion nil) + (values nil "Not a macro or compiler-macro form"))))))) + +(defslimefun macro-form-p (string compiler-macros? context) + (with-buffer-syntax () + (let ((form + (handler-case + (read-from-string string) + (error (condition) + (unless (debug-on-swank-error) + (return-from macro-form-p + `(:error ,(format nil "Read error: ~A" condition)))))))) + `(:ok ,(macro-form-type form compiler-macros? context))))) + +(defun macro-form-type (form compiler-macros? context) + (cond + ((or (not (consp form)) + (not (symbolp (car form)))) + nil) + ((multiple-value-bind (expansion expanded?) + (macroexpand-1-in-context form context) + (declare (ignore expansion)) + expanded?) + :macro) + ((and compiler-macros? + (multiple-value-bind (expansion expanded?) + (compiler-macroexpand-1 form) + (declare (ignore expansion)) + expanded?)) + :compiler-macro) + (t + nil))) + + +;;;; Hacks to support macro-expansion within local context + +(defparameter *macrostep-tag* (gensym)) + +(defparameter *macrostep-placeholder* '*macrostep-placeholder*) + +(define-condition expansion-in-context-failed (simple-error) + ()) + +(defmacro throw-expansion (form &environment env) + (throw *macrostep-tag* (macroexpand-1 form env))) + +(defmacro throw-collected-macro-forms (form &environment env) + (throw *macrostep-tag* (collect-macro-forms form env))) + +(defun macroexpand-1-in-context (form context) + (handler-case + (macroexpand-and-catch + `(throw-expansion ,form) context) + (error () + (macroexpand-1 form)))) + +(defun collect-macro-forms-in-context (form context) + (handler-case + (macroexpand-and-catch + `(throw-collected-macro-forms ,form) context) + (error () + (collect-macro-forms form)))) + +(defun macroexpand-and-catch (form context) + (catch *macrostep-tag* + (macroexpand-all (enclose-form-in-context form context)) + (error 'expansion-in-context-failed))) + +(defun enclose-form-in-context (form context) + (with-buffer-syntax () + (destructuring-bind (prefix suffix) context + (let* ((placeholder-form + (read-from-string + (concatenate + 'string + prefix (prin1-to-string *macrostep-placeholder*) suffix))) + (substituted-form (subst form *macrostep-placeholder* + placeholder-form))) + (if (not (equal placeholder-form substituted-form)) + substituted-form + (error 'expansion-in-context-failed)))))) + + +;;;; Tracking Pretty Printer + +(defun marker-char-p (char) + (<= #xe000 (char-code char) #xe8ff)) + +(defun make-marker-char (id) + ;; using the private-use characters U+E000..U+F8FF as markers, so + ;; that's our upper limit for how many we can use. + (assert (<= 0 id #x8ff)) + (code-char (+ #xe000 id))) + +(defun marker-char-id (char) + (assert (marker-char-p char)) + (- (char-code char) #xe000)) + +(defparameter +whitespace+ (mapcar #'code-char '(9 13 10 32))) + +(defun whitespacep (char) + (member char +whitespace+)) + +(defun pprint-to-string (object &optional pprint-dispatch) + (let ((*print-pprint-dispatch* (or pprint-dispatch *print-pprint-dispatch*))) + (with-bindings *macroexpand-printer-bindings* + (to-string object)))) + +#-clisp +(defun collect-form-positions (expansion printed-expansion forms) + (loop for (start end) + in (collect-marker-positions + (pprint-to-string expansion (make-tracking-pprint-dispatch forms)) + (length forms)) + collect (when (and start end) + (list (find-non-whitespace-position printed-expansion start) + (find-non-whitespace-position printed-expansion end))))) + +;; The pprint-dispatch table constructed by +;; MAKE-TRACKING-PPRINT-DISPATCH causes an infinite loop and stack +;; overflow under CLISP version 2.49. Make the COLLECT-FORM-POSITIONS +;; entry point a no-op in thi case, so that basic macro-expansion will +;; still work (without detection of inner macro forms) +#+clisp +(defun collect-form-positions (expansion printed-expansion forms) + nil) + +(defun make-tracking-pprint-dispatch (forms) + (let ((original-table *print-pprint-dispatch*) + (table (copy-pprint-dispatch))) + (flet ((maybe-write-marker (position stream) + (when position + (write-char (make-marker-char position) stream)))) + (set-pprint-dispatch 'cons + (lambda (stream cons) + (let ((pos (position cons forms))) + (maybe-write-marker pos stream) + ;; delegate printing to the original table. + (funcall (pprint-dispatch cons original-table) + stream + cons) + (maybe-write-marker pos stream))) + most-positive-fixnum + table)) + table)) + +(defun collect-marker-positions (string position-count) + (let ((positions (make-array position-count :initial-element nil))) + (loop with p = 0 + for char across string + unless (whitespacep char) + do (if (marker-char-p char) + (push p (aref positions (marker-char-id char))) + (incf p))) + (map 'list #'reverse positions))) + +(defun find-non-whitespace-position (string position) + (loop with non-whitespace-position = -1 + for i from 0 and char across string + unless (whitespacep char) + do (incf non-whitespace-position) + until (eql non-whitespace-position position) + finally (return i))) + +(provide :swank-macrostep) diff --git a/vim/bundle/slimv/slime/contrib/swank-media.lisp b/vim/bundle/slimv/slime/contrib/swank-media.lisp new file mode 100644 index 0000000..3d5ef7c --- /dev/null +++ b/vim/bundle/slimv/slime/contrib/swank-media.lisp @@ -0,0 +1,25 @@ +;;; swank-media.lisp --- insert other media (images) +;; +;; Authors: Christophe Rhodes <csr21@cantab.net> +;; +;; Licence: GPLv2 or later +;; + +(in-package :swank) + +;; this file is empty of functionality. The slime-media contrib +;; allows swank to return messages other than :write-string as repl +;; results; this is used in the R implementation of swank to display R +;; objects with graphical representations (such as trellis objects) as +;; image presentations in the swank repl. In R, this is done by +;; having a hook function for the preparation of the repl results, in +;; addition to the already-existing hook for sending the repl results +;; (*send-repl-results-function*, used by swank-presentations.lisp). +;; The swank-media.R contrib implementation defines a generic function +;; for use as this hook, along with methods for commonly-encountered +;; graphical R objects. (This strategy is harder in CL, where methods +;; can only be defined if their specializers already exist; in R's S3 +;; object system, methods are ordinary functions with a special naming +;; convention) + +(provide :swank-media) diff --git a/vim/bundle/slimv/slime/contrib/swank-mit-scheme.scm b/vim/bundle/slimv/slime/contrib/swank-mit-scheme.scm new file mode 100644 index 0000000..98af388 --- /dev/null +++ b/vim/bundle/slimv/slime/contrib/swank-mit-scheme.scm @@ -0,0 +1,882 @@ +;;; swank-mit-scheme.scm --- SLIME server for MIT Scheme +;; +;; Copyright (C) 2008 Helmut Eller +;; +;; This file is licensed under the terms of the GNU General Public +;; License as distributed with Emacs (press C-h C-c for details). + +;;;; Installation: +#| + +1. You need MIT Scheme 9.2 + +2. The Emacs side needs some fiddling. I have the following in + my .emacs: + +(setq slime-lisp-implementations + '((mit-scheme ("mit-scheme") :init mit-scheme-init))) + +(defun mit-scheme-init (file encoding) + (format "%S\n\n" + `(begin + (load-option 'format) + (load-option 'sos) + (eval + '(create-package-from-description + (make-package-description '(swank) (list (list)) + (vector) (vector) (vector) false)) + (->environment '(package))) + (load ,(expand-file-name + ".../contrib/swank-mit-scheme.scm" ; <-- insert your path + slime-path) + (->environment '(swank))) + (eval '(start-swank ,file) (->environment '(swank)))))) + +(defun mit-scheme () + (interactive) + (slime 'mit-scheme)) + +(defun find-mit-scheme-package () + (save-excursion + (let ((case-fold-search t)) + (and (re-search-backward "^[;]+ package: \\((.+)\\).*$" nil t) + (match-string-no-properties 1))))) + +(setq slime-find-buffer-package-function 'find-mit-scheme-package) +(add-hook 'scheme-mode-hook (lambda () (slime-mode 1))) + + The `mit-scheme-init' function first loads the SOS and FORMAT + libraries, then creates a package "(swank)", and loads this file + into that package. Finally it starts the server. + + `find-mit-scheme-package' tries to figure out which package the + buffer belongs to, assuming that ";;; package: (FOO)" appears + somewhere in the file. Luckily, this assumption is true for many of + MIT Scheme's own files. Alternatively, you could add Emacs style + -*- slime-buffer-package: "(FOO)" -*- file variables. + +4. Start everything with `M-x mit-scheme'. + +|# + +;;; package: (swank) + +;; Modified for Slimv: +;; - load options +;; - remove extension in compile-file-for-emacs +(load-option 'format) +(load-option 'sos) + +(if (< (car (get-subsystem-version "Release")) + '9) + (error "This file requires MIT Scheme Release 9")) + +(define (swank port) + (accept-connections (or port 4005) #f)) + +;; ### hardcoded port number for now. netcat-openbsd doesn't print +;; the listener port anymore. +(define (start-swank port-file) + (accept-connections 4055 port-file) + ) + +;;;; Networking + +(define (accept-connections port port-file) + (let ((sock (open-tcp-server-socket port (host-address-loopback)))) + (format #t "Listening on port: ~s~%" port) + (if port-file (write-port-file port port-file)) + (dynamic-wind + (lambda () #f) + (lambda () (serve (tcp-server-connection-accept sock #t #f))) + (lambda () (close-tcp-server-socket sock))))) + +(define (write-port-file portnumber filename) + (call-with-output-file filename (lambda (p) (write portnumber p)))) + +(define *top-level-restart* #f) +(define (serve socket) + (with-simple-restart + 'disconnect "Close connection." + (lambda () + (with-keyboard-interrupt-handler + (lambda () (main-loop socket)))))) + +(define (disconnect) + (format #t "Disconnecting ...~%") + (invoke-restart (find-restart 'disconnect))) + +(define (main-loop socket) + (do () (#f) + (with-simple-restart + 'abort "Return to SLIME top-level." + (lambda () + (fluid-let ((*top-level-restart* (find-restart 'abort))) + (dispatch (read-packet socket) socket 0)))))) + +(define (with-keyboard-interrupt-handler fun) + (define (set-^G-handler exp) + (eval `(vector-set! keyboard-interrupt-vector (char->ascii #\G) ,exp) + (->environment '(runtime interrupt-handler)))) + (dynamic-wind + (lambda () #f) + (lambda () + (set-^G-handler + `(lambda (char) (with-simple-restart + 'continue "Continue from interrupt." + (lambda () (error "Keyboard Interrupt."))))) + (fun)) + (lambda () + (set-^G-handler '^G-interrupt-handler)))) + + +;;;; Reading/Writing of SLIME packets + +(define (read-packet in) + "Read an S-expression from STREAM using the SLIME protocol." + (let* ((len (read-length in)) + (buffer (make-string len))) + (fill-buffer! in buffer) + (read-from-string buffer))) + +(define (write-packet message out) + (let* ((string (write-to-string message))) + (log-event "WRITE: [~a]~s~%" (string-length string) string) + (write-length (string-length string) out) + (write-string string out) + (flush-output out))) + +(define (fill-buffer! in buffer) + (read-string! buffer in)) + +(define (read-length in) + (if (eof-object? (peek-char in)) (disconnect)) + (do ((len 6 (1- len)) + (sum 0 (+ (* sum 16) (char->hex-digit (read-char in))))) + ((zero? len) sum))) + +(define (ldb size position integer) + "LoaD a Byte of SIZE bits at bit position POSITION from INTEGER." + (fix:and (fix:lsh integer (- position)) + (1- (fix:lsh 1 size)))) + +(define (write-length len out) + (do ((pos 20 (- pos 4))) + ((< pos 0)) + (write-hex-digit (ldb 4 pos len) out))) + +(define (write-hex-digit n out) + (write-char (hex-digit->char n) out)) + +(define (hex-digit->char n) + (digit->char n 16)) + +(define (char->hex-digit c) + (char->digit c 16)) + + +;;;; Event dispatching + +(define (dispatch request socket level) + (log-event "READ: ~s~%" request) + (case (car request) + ((:emacs-rex) (apply emacs-rex socket level (cdr request))))) + +(define (swank-package) + (or (name->package '(swank)) + (name->package '(user)))) + +(define *buffer-package* #f) +(define (find-buffer-package name) + (if (elisp-false? name) + #f + (let ((v (ignore-errors + (lambda () (name->package (read-from-string name)))))) + (and (package? v) v)))) + +(define swank-env (->environment (swank-package))) +(define (user-env buffer-package) + (cond ((string? buffer-package) + (let ((p (find-buffer-package buffer-package))) + (if (not p) (error "Invalid package name: " buffer-package)) + (package/environment p))) + (else (nearest-repl/environment)))) + +;; quote keywords +(define (hack-quotes list) + (map (lambda (x) + (cond ((symbol? x) `(quote ,x)) + (#t x))) + list)) + +(define (emacs-rex socket level sexp package thread id) + (let ((ok? #f) (result #f) (condition #f)) + (dynamic-wind + (lambda () #f) + (lambda () + (bind-condition-handler + (list condition-type:serious-condition) + (lambda (c) (set! condition c) (invoke-sldb socket (1+ level) c)) + (lambda () + (fluid-let ((*buffer-package* package)) + (set! result + (eval (cons* (car sexp) socket (hack-quotes (cdr sexp))) + swank-env)) + (set! ok? #t))))) + (lambda () + (write-packet `(:return + ,(if ok? `(:ok ,result) + `(:abort + ,(if condition + (format #f "~a" + (condition/type condition)) + "<unknown reason>"))) + ,id) + socket))))) + +(define (swank:connection-info _) + (let ((p (environment->package (user-env #f)))) + `(:pid ,(unix/current-pid) + :package (:name ,(write-to-string (package/name p)) + :prompt ,(write-to-string (package/name p))) + :lisp-implementation + (:type "MIT Scheme" :version ,(get-subsystem-version-string "release")) + :encoding (:coding-systems ("iso-8859-1")) + ))) + +(define (swank:quit-lisp _) + (%exit)) + + +;;;; Evaluation + +(define (swank-repl:listener-eval socket string) + ;;(call-with-values (lambda () (eval-region string socket)) + ;; (lambda values `(:values . ,(map write-to-string values)))) + `(:values ,(write-to-string (eval-region string socket)))) + +(define (eval-region string socket) + (let ((sexp (read-from-string string))) + (if (eof-object? exp) + (values) + (with-output-to-repl socket + (lambda () (eval sexp (user-env *buffer-package*))))))) + +(define (with-output-to-repl socket fun) + (let ((p (make-port repl-port-type socket))) + (dynamic-wind + (lambda () #f) + (lambda () (with-output-to-port p fun)) + (lambda () (flush-output p))))) + +(define (swank:interactive-eval socket string) + ;;(call-with-values (lambda () (eval-region string)) format-for-echo-area) + (format-values (eval-region string socket)) + ) + +(define (format-values . values) + (if (null? values) + "; No value" + (with-string-output-port + (lambda (out) + (write-string "=> " out) + (do ((vs values (cdr vs))) ((null? vs)) + (write (car vs) out) + (if (not (null? (cdr vs))) + (write-string ", " out))))))) + +(define (swank:pprint-eval _ string) + (pprint-to-string (eval (read-from-string string) + (user-env *buffer-package*)))) + +(define (swank:interactive-eval-region socket string) + (format-values (eval-region string socket))) + +(define (swank:set-package _ package) + (set-repl/environment! (nearest-repl) + (->environment (read-from-string package))) + (let* ((p (environment->package (user-env #f))) + (n (write-to-string (package/name p)))) + (list n n))) + + +(define (repl-write-substring port string start end) + (cond ((< start end) + (write-packet `(:write-string ,(substring string start end)) + (port/state port)))) + (- end start)) + +(define (repl-write-char port char) + (write-packet `(:write-string ,(string char)) + (port/state port))) + +(define repl-port-type + (make-port-type `((write-substring ,repl-write-substring) + (write-char ,repl-write-char)) #f)) + +(define (swank-repl:create-repl socket . _) + (let* ((env (user-env #f)) + (name (format #f "~a" (package/name (environment->package env))))) + (list name name))) + + +;;;; Compilation + +(define (swank:compile-string-for-emacs _ string . x) + (apply + (lambda (errors seconds) + `(:compilation-result ,errors t ,seconds nil nil)) + (call-compiler + (lambda () + (let* ((sexps (snarf-string string)) + (env (user-env *buffer-package*)) + (scode (syntax `(begin ,@sexps) env)) + (compiled-expression (compile-scode scode #t))) + (scode-eval compiled-expression env)))))) + +(define (snarf-string string) + (with-input-from-string string + (lambda () + (let loop () + (let ((e (read))) + (if (eof-object? e) '() (cons e (loop)))))))) + +(define (call-compiler fun) + (let ((time #f)) + (with-timings fun + (lambda (run-time gc-time real-time) + (set! time real-time))) + (list 'nil (internal-time/ticks->seconds time)))) + +(define (swank:compiler-notes-for-emacs _) nil) + +(define (swank:compile-file-for-emacs socket file load?) + (apply + (lambda (errors seconds) + (list ':compilation-result errors 't seconds load? + (->namestring (pathname-name file)))) + (call-compiler + (lambda () (with-output-to-repl socket (lambda () (compile-file file))))))) + +(define (swank:load-file socket file) + (with-output-to-repl socket + (lambda () + (pprint-to-string + (load file (user-env *buffer-package*)))))) + +(define (swank:disassemble-form _ string) + (let ((sexp (let ((sexp (read-from-string string))) + (cond ((and (pair? sexp) (eq? (car sexp) 'quote)) + (cadr sexp)) + (#t sexp))))) + (with-output-to-string + (lambda () + (compiler:disassemble + (eval sexp (user-env *buffer-package*))))))) + +(define (swank:disassemble-symbol _ string) + (with-output-to-string + (lambda () + (compiler:disassemble + (eval (read-from-string string) + (user-env *buffer-package*)))))) + + +;;;; Macroexpansion + +(define (swank:swank-macroexpand-all _ string) + (with-output-to-string + (lambda () + (pp (syntax (read-from-string string) + (user-env *buffer-package*)))))) +(define swank:swank-macroexpand-1 swank:swank-macroexpand-all) +(define swank:swank-macroexpand swank:swank-macroexpand-all) + + +;;; Arglist + +(define (swank:operator-arglist socket name pack) + (let ((v (ignore-errors + (lambda () + (string-trim-right + (with-output-to-string + (lambda () + (carefully-pa + (eval (read-from-string name) (user-env pack)))))))))) + (if (condition? v) 'nil v))) + +(define (carefully-pa o) + (cond ((arity-dispatched-procedure? o) + ;; MIT Scheme crashes for (pa /) + (display "arity-dispatched-procedure")) + ((procedure? o) (pa o)) + (else (error "Not a procedure")))) + + +;;; Some unimplemented stuff. +(define (swank:buffer-first-change . _) nil) +(define (swank:filename-to-modulename . _) nil) +(define (swank:swank-require . _) nil) + +;; M-. is beyond my capabilities. +(define (swank:find-definitions-for-emacs . _) nil) + + +;;; Debugger + +(define-structure (sldb-state (conc-name sldb-state.)) condition restarts) + +(define *sldb-state* #f) +(define (invoke-sldb socket level condition) + (fluid-let ((*sldb-state* (make-sldb-state condition (bound-restarts)))) + (dynamic-wind + (lambda () #f) + (lambda () + (write-packet `(:debug 0 ,level ,@(sldb-info *sldb-state* 0 20)) + socket) + (sldb-loop level socket)) + (lambda () + (write-packet `(:debug-return 0 ,level nil) socket))))) + +(define (sldb-loop level socket) + (write-packet `(:debug-activate 0 ,level) socket) + (with-simple-restart + 'abort (format #f "Return to SLDB level ~a." level) + (lambda () (dispatch (read-packet socket) socket level))) + (sldb-loop level socket)) + +(define (sldb-info state start end) + (let ((c (sldb-state.condition state)) + (rs (sldb-state.restarts state))) + (list (list (condition/report-string c) + (format #f " [~a]" (%condition-type/name (condition/type c))) + nil) + (sldb-restarts rs) + (sldb-backtrace c start end) + ;;'((0 "dummy frame")) + '()))) + +(define %condition-type/name + (eval '%condition-type/name (->environment '(runtime error-handler)))) + +(define (sldb-restarts restarts) + (map (lambda (r) + (list (symbol->string (restart/name r)) + (with-string-output-port + (lambda (p) (write-restart-report r p))))) + restarts)) + +(define (swank:throw-to-toplevel . _) + (invoke-restart *top-level-restart*)) + +(define (swank:sldb-abort . _) + (abort (sldb-state.restarts *sldb-state*))) + +(define (swank:sldb-continue . _) + (continue (sldb-state.restarts *sldb-state*))) + +(define (swank:invoke-nth-restart-for-emacs _ _sldb-level n) + (invoke-restart (list-ref (sldb-state.restarts *sldb-state*) n))) + +(define (swank:debugger-info-for-emacs _ from to) + (sldb-info *sldb-state* from to)) + +(define (swank:backtrace _ from to) + (sldb-backtrace (sldb-state.condition *sldb-state*) from to)) + +(define (sldb-backtrace condition from to) + (sldb-backtrace-aux (condition/continuation condition) from to)) + +(define (sldb-backtrace-aux k from to) + (let ((l (map frame>string (substream (continuation>frames k) from to)))) + (let loop ((i from) (l l)) + (if (null? l) + '() + (cons (list i (car l)) (loop (1+ i) (cdr l))))))) + +;; Stack parser fails for this: +;; (map (lambda (x) x) "/tmp/x.x") + +(define (continuation>frames k) + (let loop ((frame (continuation->stack-frame k))) + (cond ((not frame) (stream)) + (else + (let ((next (ignore-errors + (lambda () (stack-frame/next-subproblem frame))))) + (cons-stream frame + (if (condition? next) + (stream next) + (loop next)))))))) + +(define (frame>string frame) + (if (condition? frame) + (format #f "Bogus frame: ~a ~a" frame + (condition/report-string frame)) + (with-string-output-port (lambda (p) (print-frame frame p))))) + +(define (print-frame frame port) + (define (invalid-subexpression? subexpression) + (or (debugging-info/undefined-expression? subexpression) + (debugging-info/unknown-expression? subexpression))) + (define (invalid-expression? expression) + (or (debugging-info/undefined-expression? expression) + (debugging-info/compiled-code? expression))) + (with-values (lambda () (stack-frame/debugging-info frame)) + (lambda (expression environment subexpression) + (cond ((debugging-info/compiled-code? expression) + (write-string ";unknown compiled code" port)) + ((not (debugging-info/undefined-expression? expression)) + (fluid-let ((*unparse-primitives-by-name?* #t)) + (write + (unsyntax (if (invalid-subexpression? subexpression) + expression + subexpression)) + port))) + ((debugging-info/noise? expression) + (write-string ";" port) + (write-string ((debugging-info/noise expression) #f) + port)) + (else + (write-string ";undefined expression" port)))))) + +(define (substream s from to) + (let loop ((i 0) (l '()) (s s)) + (cond ((or (= i to) (stream-null? s)) (reverse l)) + ((< i from) (loop (1+ i) l (stream-cdr s))) + (else (loop (1+ i) (cons (stream-car s) l) (stream-cdr s)))))) + +(define (swank:frame-locals-and-catch-tags _ frame) + (list (map frame-var>elisp (frame-vars (sldb-get-frame frame))) + '())) + +(define (frame-vars frame) + (with-values (lambda () (stack-frame/debugging-info frame)) + (lambda (expression environment subexpression) + (cond ((environment? environment) + (environment>frame-vars environment)) + (else '()))))) + +(define (environment>frame-vars environment) + (let loop ((e environment)) + (cond ((environment->package e) '()) + (else (append (environment-bindings e) + (if (environment-has-parent? e) + (loop (environment-parent e)) + '())))))) + +(define (frame-var>elisp b) + (list ':name (write-to-string (car b)) + ':value (cond ((null? (cdr b)) "{unavailable}") + (else (>line (cadr b)))) + ':id 0)) + +(define (sldb-get-frame index) + (stream-ref (continuation>frames + (condition/continuation + (sldb-state.condition *sldb-state*))) + index)) + +(define (frame-var-value frame var) + (let ((binding (list-ref (frame-vars frame) var))) + (cond ((cdr binding) (cadr binding)) + (else unspecific)))) + +(define (swank:inspect-frame-var _ frame var) + (reset-inspector) + (inspect-object (frame-var-value (sldb-get-frame frame) var))) + + +;;;; Completion + +(define (swank:simple-completions _ string package) + (let ((strings (all-completions string (user-env package) string-prefix?))) + (list (sort strings string<?) + (longest-common-prefix strings)))) + +(define (all-completions pattern env match?) + (let ((ss (map %symbol->string (environment-names env)))) + (keep-matching-items ss (lambda (s) (match? pattern s))))) + +;; symbol->string is too slow +(define %symbol->string symbol-name) + +(define (environment-names env) + (append (environment-bound-names env) + (if (environment-has-parent? env) + (environment-names (environment-parent env)) + '()))) + +(define (longest-common-prefix strings) + (define (common-prefix s1 s2) + (substring s1 0 (string-match-forward s1 s2))) + (reduce common-prefix "" strings)) + + +;;;; Apropos + +(define (swank:apropos-list-for-emacs _ name #!optional + external-only case-sensitive package) + (let* ((pkg (and (string? package) + (find-package (read-from-string package)))) + (parent (and (not (default-object? external-only)) + (elisp-false? external-only))) + (ss (append-map (lambda (p) + (map (lambda (s) (cons p s)) + (apropos-list name p (and pkg parent)))) + (if pkg (list pkg) (all-packages)))) + (ss (sublist ss 0 (min (length ss) 200)))) + (map (lambda (e) + (let ((p (car e)) (s (cdr e))) + (list ':designator (format #f "~a ~a" s (package/name p)) + ':variable (>line + (ignore-errors + (lambda () (package-lookup p s))))))) + ss))) + +(define (swank:list-all-package-names . _) + (map (lambda (p) (write-to-string (package/name p))) + (all-packages))) + +(define (all-packages) + (define (package-and-children package) + (append (list package) + (append-map package-and-children (package/children package)))) + (package-and-children system-global-package)) + + +;;;; Inspector + +(define-structure (inspector-state (conc-name istate.)) + object parts next previous content) + +(define istate #f) + +(define (reset-inspector) + (set! istate #f)) + +(define (swank:init-inspector _ string) + (reset-inspector) + (inspect-object (eval (read-from-string string) + (user-env *buffer-package*)))) + +(define (inspect-object o) + (let ((previous istate) + (content (inspect o)) + (parts (make-eqv-hash-table))) + (set! istate (make-inspector-state o parts #f previous content)) + (if previous (set-istate.next! previous istate)) + (istate>elisp istate))) + +(define (istate>elisp istate) + (list ':title (>line (istate.object istate)) + ':id (assign-index (istate.object istate) (istate.parts istate)) + ':content (prepare-range (istate.parts istate) + (istate.content istate) + 0 500))) + +(define (assign-index o parts) + (let ((i (hash-table/count parts))) + (hash-table/put! parts i o) + i)) + +(define (prepare-range parts content from to) + (let* ((cs (substream content from to)) + (ps (prepare-parts cs parts))) + (list ps + (if (< (length cs) (- to from)) + (+ from (length cs)) + (+ to 1000)) + from to))) + +(define (prepare-parts ps parts) + (define (line label value) + `(,(format #f "~a: " label) + (:value ,(>line value) ,(assign-index value parts)) + "\n")) + (append-map (lambda (p) + (cond ((string? p) (list p)) + ((symbol? p) (list (symbol->string p))) + (#t + (case (car p) + ((line) (apply line (cdr p))) + (else (error "Invalid part:" p)))))) + ps)) + +(define (swank:inspect-nth-part _ index) + (inspect-object (hash-table/get (istate.parts istate) index 'no-such-part))) + +(define (swank:quit-inspector _) + (reset-inspector)) + +(define (swank:inspector-pop _) + (cond ((istate.previous istate) + (set! istate (istate.previous istate)) + (istate>elisp istate)) + (else 'nil))) + +(define (swank:inspector-next _) + (cond ((istate.next istate) + (set! istate (istate.next istate)) + (istate>elisp istate)) + (else 'nil))) + +(define (swank:inspector-range _ from to) + (prepare-range (istate.parts istate) + (istate.content istate) + from to)) + +(define-syntax stream* + (syntax-rules () + ((stream* tail) tail) + ((stream* e1 e2 ...) (cons-stream e1 (stream* e2 ...))))) + +(define (iline label value) `(line ,label ,value)) + +(define-generic inspect (o)) + +(define-method inspect ((o <object>)) + (cond ((environment? o) (inspect-environment o)) + ((vector? o) (inspect-vector o)) + ((procedure? o) (inspect-procedure o)) + ((compiled-code-block? o) (inspect-code-block o)) + ;;((system-pair? o) (inspect-system-pair o)) + ((probably-scode? o) (inspect-scode o)) + (else (inspect-fallback o)))) + +(define (inspect-fallback o) + (let* ((class (object-class o)) + (slots (class-slots class))) + (stream* + (iline "Class" class) + (let loop ((slots slots)) + (cond ((null? slots) (stream)) + (else + (let ((n (slot-name (car slots)))) + (stream* (iline n (slot-value o n)) + (loop (cdr slots)))))))))) + +(define-method inspect ((o <pair>)) + (if (or (pair? (cdr o)) (null? (cdr o))) + (inspect-list o) + (inspect-cons o))) + +(define (inspect-cons o) + (stream (iline "car" (car o)) + (iline "cdr" (cdr o)))) + +(define (inspect-list o) + (let loop ((i 0) (o o)) + (cond ((null? o) (stream)) + ((or (pair? (cdr o)) (null? (cdr o))) + (stream* (iline i (car o)) + (loop (1+ i) (cdr o)))) + (else + (stream (iline i (car o)) + (iline "tail" (cdr o))))))) + +(define (inspect-environment o) + (stream* + (iline "(package)" (environment->package o)) + (let loop ((bs (environment-bindings o))) + (cond ((null? bs) + (if (environment-has-parent? o) + (stream (iline "(<parent>)" (environment-parent o))) + (stream))) + (else + (let* ((b (car bs)) (s (car b))) + (cond ((null? (cdr b)) + (stream* s " {" (environment-reference-type o s) "}\n" + (loop (cdr bs)))) + (else + (stream* (iline s (cadr b)) + (loop (cdr bs))))))))))) + +(define (inspect-vector o) + (let ((len (vector-length o))) + (let loop ((i 0)) + (cond ((= i len) (stream)) + (else (stream* (iline i (vector-ref o i)) + (loop (1+ i)))))))) + +(define (inspect-procedure o) + (cond ((primitive-procedure? o) + (stream (iline "name" (primitive-procedure-name o)) + (iline "arity" (primitive-procedure-arity o)) + (iline "doc" (primitive-procedure-documentation o)))) + ((compound-procedure? o) + (stream (iline "arity" (procedure-arity o)) + (iline "lambda" (procedure-lambda o)) + (iline "env" (ignore-errors + (lambda () (procedure-environment o)))))) + (else + (stream + (iline "block" (compiled-entry/block o)) + (with-output-to-string (lambda () (compiler:disassemble o))))))) + +(define (inspect-code-block o) + (stream-append + (let loop ((i (compiled-code-block/constants-start o))) + (cond ((>= i (compiled-code-block/constants-end o)) (stream)) + (else + (stream* + (iline i (system-vector-ref o i)) + (loop (+ i compiled-code-block/bytes-per-object)))))) + (stream (iline "debuginfo" (compiled-code-block/debugging-info o)) + (iline "env" (compiled-code-block/environment o)) + (with-output-to-string (lambda () (compiler:disassemble o)))))) + +(define (inspect-scode o) + (stream (pprint-to-string o))) + +(define (probably-scode? o) + (define tests (list access? assignment? combination? comment? + conditional? definition? delay? disjunction? lambda? + quotation? sequence? the-environment? variable?)) + (let loop ((tests tests)) + (cond ((null? tests) #f) + (((car tests) o)) + (else (loop (cdr tests)))))) + +(define (inspect-system-pair o) + (stream (iline "car" (system-pair-car o)) + (iline "cdr" (system-pair-cdr o)))) + + +;;;; Auxilary functions + +(define nil '()) +(define t 't) +(define (elisp-false? o) (member o '(nil ()))) +(define (elisp-true? o) (not (elisp-false? o))) +(define (>line o) + (let ((r (write-to-string o 100))) + (cond ((not (car r)) (cdr r)) + (else (string-append (cdr r) " .."))))) +;; Must compile >line otherwise we can't write unassigend-reference-traps. +(set! >line (compile-procedure >line)) +(define (read-from-string s) (with-input-from-string s read)) +(define (pprint-to-string o) + (with-string-output-port + (lambda (p) + (fluid-let ((*unparser-list-breadth-limit* 10) + (*unparser-list-depth-limit* 4) + (*unparser-string-length-limit* 100)) + (pp o p))))) +;(define (1+ n) (+ n 1)) +(define (1- n) (- n 1)) +(define (package-lookup package name) + (let ((p (if (package? package) package (find-package package)))) + (environment-lookup (package/environment p) name))) +(define log-port (current-output-port)) +(define (log-event fstring . args) + ;;(apply format log-port fstring args) + #f + ) + +;; Modified for Slimv: +;; - restart swank server in a loop +(let loop () + (swank 4005) + (loop)) + +;;; swank-mit-scheme.scm ends here diff --git a/vim/bundle/slimv/slime/contrib/swank-mrepl.lisp b/vim/bundle/slimv/slime/contrib/swank-mrepl.lisp new file mode 100644 index 0000000..cc8ce81 --- /dev/null +++ b/vim/bundle/slimv/slime/contrib/swank-mrepl.lisp @@ -0,0 +1,162 @@ +;;; swank-mrepl.lisp +;; +;; Licence: public domain + +(in-package :swank) +(eval-when (:compile-toplevel :load-toplevel :execute) + (let ((api '( + *emacs-connection* + channel + channel-id + define-channel-method + defslimefun + dcase + log-event + process-requests + send-to-remote-channel + use-threads-p + wait-for-event + with-bindings + with-connection + with-top-level-restart + with-slime-interrupts + ))) + (eval `(defpackage #:swank-api + (:use) + (:import-from #:swank . ,api) + (:export . ,api))))) + +(defpackage :swank-mrepl + (:use :cl :swank-api) + (:export #:create-mrepl)) + +(in-package :swank-mrepl) + +(defclass listener-channel (channel) + ((remote :initarg :remote) + (env :initarg :env) + (mode :initform :eval) + (tag :initform nil))) + +(defun package-prompt (package) + (reduce (lambda (x y) (if (<= (length x) (length y)) x y)) + (cons (package-name package) (package-nicknames package)))) + +(defslimefun create-mrepl (remote) + (let* ((pkg *package*) + (conn *emacs-connection*) + (thread (if (use-threads-p) + (spawn-listener-thread conn) + nil)) + (ch (make-instance 'listener-channel :remote remote :thread thread))) + (setf (slot-value ch 'env) (initial-listener-env ch)) + (when thread + (swank/backend:send thread `(:serve-channel ,ch))) + (list (channel-id ch) + (swank/backend:thread-id (or thread (swank/backend:current-thread))) + (package-name pkg) + (package-prompt pkg)))) + +(defun initial-listener-env (listener) + `((*package* . ,*package*) + (*standard-output* . ,(make-listener-output-stream listener)) + (*standard-input* . ,(make-listener-input-stream listener)))) + +(defun spawn-listener-thread (connection) + (swank/backend:spawn + (lambda () + (with-connection (connection) + (dcase (swank/backend:receive) + ((:serve-channel c) + (loop + (with-top-level-restart (connection (drop-unprocessed-events c)) + (process-requests nil))))))) + :name "mrepl thread")) + +(defun drop-unprocessed-events (channel) + (with-slots (mode) channel + (let ((old-mode mode)) + (setf mode :drop) + (unwind-protect + (process-requests t) + (setf mode old-mode))) + (send-prompt channel))) + +(define-channel-method :process ((c listener-channel) string) + (log-event ":process ~s~%" string) + (with-slots (mode remote) c + (ecase mode + (:eval (mrepl-eval c string)) + (:read (mrepl-read c string)) + (:drop)))) + +(defun mrepl-eval (channel string) + (with-slots (remote env) channel + (let ((aborted t)) + (with-bindings env + (unwind-protect + (let ((result (with-slime-interrupts (read-eval-print string)))) + (send-to-remote-channel remote `(:write-result ,result)) + (setq aborted nil)) + (setf env (loop for (sym) in env + collect (cons sym (symbol-value sym)))) + (cond (aborted + (send-to-remote-channel remote `(:evaluation-aborted))) + (t + (send-prompt channel)))))))) + +(defun send-prompt (channel) + (with-slots (env remote) channel + (let ((pkg (or (cdr (assoc '*package* env)) *package*)) + (out (cdr (assoc '*standard-output* env))) + (in (cdr (assoc '*standard-input* env)))) + (when out (force-output out)) + (when in (clear-input in)) + (send-to-remote-channel remote `(:prompt ,(package-name pkg) + ,(package-prompt pkg)))))) + +(defun mrepl-read (channel string) + (with-slots (tag) channel + (assert tag) + (throw tag string))) + +(defun read-eval-print (string) + (with-input-from-string (in string) + (setq / ()) + (loop + (let* ((form (read in nil in))) + (cond ((eq form in) (return)) + (t (setq / (multiple-value-list (eval (setq + form)))))))) + (force-output) + (if / + (format nil "~{~s~%~}" /) + "; No values"))) + +(defun make-listener-output-stream (channel) + (let ((remote (slot-value channel 'remote))) + (swank/backend:make-output-stream + (lambda (string) + (send-to-remote-channel remote `(:write-string ,string)))))) + +(defun make-listener-input-stream (channel) + (swank/backend:make-input-stream (lambda () (read-input channel)))) + +(defun set-mode (channel new-mode) + (with-slots (mode remote) channel + (unless (eq mode new-mode) + (send-to-remote-channel remote `(:set-read-mode ,new-mode))) + (setf mode new-mode))) + +(defun read-input (channel) + (with-slots (mode tag remote) channel + (force-output) + (let ((old-mode mode) + (old-tag tag)) + (setf tag (cons nil nil)) + (set-mode channel :read) + (unwind-protect + (catch tag (process-requests nil)) + (setf tag old-tag) + (set-mode channel old-mode))))) + +(provide :swank-mrepl) diff --git a/vim/bundle/slimv/slime/contrib/swank-package-fu.lisp b/vim/bundle/slimv/slime/contrib/swank-package-fu.lisp new file mode 100644 index 0000000..a22807a --- /dev/null +++ b/vim/bundle/slimv/slime/contrib/swank-package-fu.lisp @@ -0,0 +1,65 @@ + +(in-package :swank) + +(defslimefun package= (string1 string2) + (let* ((pkg1 (guess-package string1)) + (pkg2 (guess-package string2))) + (and pkg1 pkg2 (eq pkg1 pkg2)))) + +(defslimefun export-symbol-for-emacs (symbol-str package-str) + (let ((package (guess-package package-str))) + (when package + (let ((*buffer-package* package)) + (export `(,(from-string symbol-str)) package))))) + +(defslimefun unexport-symbol-for-emacs (symbol-str package-str) + (let ((package (guess-package package-str))) + (when package + (let ((*buffer-package* package)) + (unexport `(,(from-string symbol-str)) package))))) + +#+sbcl +(defun list-structure-symbols (name) + (let ((dd (sb-kernel:find-defstruct-description name ))) + (list* name + (sb-kernel:dd-default-constructor dd) + (sb-kernel:dd-predicate-name dd) + (sb-kernel::dd-copier-name dd) + (mapcar #'sb-kernel:dsd-accessor-name + (sb-kernel:dd-slots dd))))) + +#+ccl +(defun list-structure-symbols (name) + (let ((definition (gethash name ccl::%defstructs%))) + (list* name + (ccl::sd-constructor definition) + (ccl::sd-refnames definition)))) + +(defun list-class-symbols (name) + (let* ((class (find-class name)) + (slots (swank-mop:class-direct-slots class))) + (labels ((extract-symbol (name) + (if (and (consp name) (eql (car name) 'setf)) + (cadr name) + name)) + (slot-accessors (slot) + (nintersection (copy-list (swank-mop:slot-definition-readers slot)) + (copy-list (swank-mop:slot-definition-readers slot)) + :key #'extract-symbol))) + (list* (class-name class) + (mapcan #'slot-accessors slots))))) + +(defslimefun export-structure (name package) + (let ((*package* (guess-package package))) + (when *package* + (let* ((name (from-string name)) + (symbols (cond #+(or sbcl ccl) + ((or (not (find-class name nil)) + (subtypep name 'structure-object)) + (list-structure-symbols name)) + (t + (list-class-symbols name))))) + (export symbols) + symbols)))) + +(provide :swank-package-fu) diff --git a/vim/bundle/slimv/slime/contrib/swank-presentation-streams.lisp b/vim/bundle/slimv/slime/contrib/swank-presentation-streams.lisp new file mode 100644 index 0000000..a83d62e --- /dev/null +++ b/vim/bundle/slimv/slime/contrib/swank-presentation-streams.lisp @@ -0,0 +1,334 @@ +;;; swank-presentation-streams.lisp --- Streams that allow attaching object identities +;;; to portions of output +;;; +;;; Authors: Alan Ruttenberg <alanr-l@mumble.net> +;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> +;;; Helmut Eller <heller@common-lisp.net> +;;; +;;; License: This code has been placed in the Public Domain. All warranties +;;; are disclaimed. + +(in-package :swank) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (swank-require :swank-presentations)) + +;; This file contains a mechanism for printing to the slime repl so +;; that the printed result remembers what object it is associated +;; with. This extends the recording of REPL results. +;; +;; There are two methods: +;; +;; 1. Depends on the ilisp bridge code being installed and ready to +;; intercept messages in the printed stream. We encode the +;; information with a message saying that we are starting to print +;; an object corresponding to a given id and another when we are +;; done. The process filter notices these and adds the necessary +;; text properties to the output. +;; +;; 2. Use separate protocol messages :presentation-start and +;; :presentation-end for sending presentations. +;; +;; We only do this if we know we are printing to a slime stream, +;; checked with the method slime-stream-p. Initially this checks for +;; the knows slime streams looking at *connections*. In cmucl, sbcl, and +;; openmcl it also checks if it is a pretty-printing stream which +;; ultimately prints to a slime stream. +;; +;; Method 1 seems to be faster, but the printed escape sequences can +;; disturb the column counting, and thus the layout in pretty-printing. +;; We use method 1 when a dedicated output stream is used. +;; +;; Method 2 is cleaner and works with pretty printing if the pretty +;; printers support "annotations". We use method 2 when no dedicated +;; output stream is used. + +;; Control +(defvar *enable-presenting-readable-objects* t + "set this to enable automatically printing presentations for some +subset of readable objects, such as pathnames." ) + +;; doing it + +(defmacro presenting-object (object stream &body body) + "What you use in your code. Wrap this around some printing and that text will +be sensitive and remember what object it is in the repl" + `(presenting-object-1 ,object ,stream #'(lambda () ,@body))) + +(defmacro presenting-object-if (predicate object stream &body body) + "What you use in your code. Wrap this around some printing and that text will +be sensitive and remember what object it is in the repl if predicate is true" + (let ((continue (gensym))) + `(let ((,continue #'(lambda () ,@body))) + (if ,predicate + (presenting-object-1 ,object ,stream ,continue) + (funcall ,continue))))) + +;;; Get pretty printer patches for SBCL at load (not compile) time. +#+#:disable-dangerous-patching ; #+sbcl +(eval-when (:load-toplevel) + (handler-bind ((simple-error + (lambda (c) + (declare (ignore c)) + (let ((clobber-it (find-restart 'sb-kernel::clobber-it))) + (when clobber-it (invoke-restart clobber-it)))))) + (sb-ext:without-package-locks + (swank/sbcl::with-debootstrapping + (load (make-pathname + :name "sbcl-pprint-patch" + :type "lisp" + :directory (pathname-directory + swank-loader:*source-directory*))))))) + +(let ((last-stream nil) + (last-answer nil)) + (defun slime-stream-p (stream) + "Check if stream is one of the slime streams, since if it isn't we +don't want to present anything. +Two special return values: +:DEDICATED -- Output ends up on a dedicated output stream +:REPL-RESULT -- Output ends up on the :repl-results target. +" + (if (eq last-stream stream) + last-answer + (progn + (setq last-stream stream) + (if (eq stream t) + (setq stream *standard-output*)) + (setq last-answer + (or #+openmcl + (and (typep stream 'ccl::xp-stream) + ;(slime-stream-p (ccl::xp-base-stream (slot-value stream 'ccl::xp-structure))) + (slime-stream-p (ccl::%svref (slot-value stream 'ccl::xp-structure) 1))) + #+cmu + (or (and (typep stream 'lisp::indenting-stream) + (slime-stream-p (lisp::indenting-stream-stream stream))) + (and (typep stream 'pretty-print::pretty-stream) + (fboundp 'pretty-print::enqueue-annotation) + (let ((slime-stream-p + (slime-stream-p (pretty-print::pretty-stream-target stream)))) + (and ;; Printing through CMUCL pretty + ;; streams is only cleanly + ;; possible if we are using the + ;; bridge-less protocol with + ;; annotations, because the bridge + ;; escape sequences disturb the + ;; pretty printer layout. + (not (eql slime-stream-p :dedicated-output)) + ;; If OK, return the return value + ;; we got from slime-stream-p on + ;; the target stream (could be + ;; :repl-result): + slime-stream-p)))) + #+sbcl + (let () + (declare (notinline sb-pretty::pretty-stream-target)) + (and (typep stream (find-symbol "PRETTY-STREAM" 'sb-pretty)) + (find-symbol "ENQUEUE-ANNOTATION" 'sb-pretty) + (not *use-dedicated-output-stream*) + (slime-stream-p (sb-pretty::pretty-stream-target stream)))) + #+allegro + (and (typep stream 'excl:xp-simple-stream) + (slime-stream-p (excl::stream-output-handle stream))) + (loop for connection in *connections* + thereis (or (and (eq stream (connection.dedicated-output connection)) + :dedicated) + (eq stream (connection.socket-io connection)) + (eq stream (connection.user-output connection)) + (eq stream (connection.user-io connection)) + (and (eq stream (connection.repl-results connection)) + :repl-result))))))))) + +(defun can-present-readable-objects (&optional stream) + (declare (ignore stream)) + *enable-presenting-readable-objects*) + +;; If we are printing to an XP (pretty printing) stream, printing the +;; escape sequences directly would mess up the layout because column +;; counting is disturbed. Use "annotations" instead. +#+allegro +(defun write-annotation (stream function arg) + (if (typep stream 'excl:xp-simple-stream) + (excl::schedule-annotation stream function arg) + (funcall function arg stream nil))) +#+cmu +(defun write-annotation (stream function arg) + (if (and (typep stream 'pp:pretty-stream) + (fboundp 'pp::enqueue-annotation)) + (pp::enqueue-annotation stream function arg) + (funcall function arg stream nil))) +#+sbcl +(defun write-annotation (stream function arg) + (let ((enqueue-annotation + (find-symbol "ENQUEUE-ANNOTATION" 'sb-pretty))) + (if (and enqueue-annotation + (typep stream (find-symbol "PRETTY-STREAM" 'sb-pretty))) + (funcall enqueue-annotation stream function arg) + (funcall function arg stream nil)))) +#-(or allegro cmu sbcl) +(defun write-annotation (stream function arg) + (funcall function arg stream nil)) + +(defstruct presentation-record + (id) + (printed-p) + (target)) + +(defun presentation-start (record stream truncatep) + (unless truncatep + ;; Don't start new presentations when nothing is going to be + ;; printed due to *print-lines*. + (let ((pid (presentation-record-id record)) + (target (presentation-record-target record))) + (case target + (:dedicated + ;; Use bridge protocol + (write-string "<" stream) + (prin1 pid stream) + (write-string " " stream)) + (t + (finish-output stream) + (send-to-emacs `(:presentation-start ,pid ,target))))) + (setf (presentation-record-printed-p record) t))) + +(defun presentation-end (record stream truncatep) + (declare (ignore truncatep)) + ;; Always end old presentations that were started. + (when (presentation-record-printed-p record) + (let ((pid (presentation-record-id record)) + (target (presentation-record-target record))) + (case target + (:dedicated + ;; Use bridge protocol + (write-string ">" stream) + (prin1 pid stream) + (write-string " " stream)) + (t + (finish-output stream) + (send-to-emacs `(:presentation-end ,pid ,target))))))) + +(defun presenting-object-1 (object stream continue) + "Uses the bridge mechanism with two messages >id and <id. The first one +says that I am starting to print an object with this id. The second says I am finished" + ;; this declare special is to let the compiler know that *record-repl-results* will eventually be + ;; a global special, even if it isn't when this file is compiled/loaded. + (declare (special *record-repl-results*)) + (let ((slime-stream-p + (and *record-repl-results* (slime-stream-p stream)))) + (if slime-stream-p + (let* ((pid (swank::save-presented-object object)) + (record (make-presentation-record :id pid :printed-p nil + :target (if (eq slime-stream-p :repl-result) + :repl-result + nil)))) + (write-annotation stream #'presentation-start record) + (multiple-value-prog1 + (funcall continue) + (write-annotation stream #'presentation-end record))) + (funcall continue)))) + +(defun present-repl-results-via-presentation-streams (values) + ;; Override a function in swank.lisp, so that + ;; nested presentations work in the REPL result. + (let ((repl-results (connection.repl-results *emacs-connection*))) + (flet ((send (value) + (presenting-object value repl-results + (prin1 value repl-results)) + (terpri repl-results))) + (if (null values) + (progn + (princ "; No value" repl-results) + (terpri repl-results)) + (mapc #'send values))) + (finish-output repl-results))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +#+openmcl +(in-package :ccl) + +#+openmcl +(defun monkey-patch-stream-printing () + (let ((*warn-if-redefine-kernel* nil) + (*warn-if-redefine* nil)) + (defun %print-unreadable-object (object stream type id thunk) + (cond ((null stream) (setq stream *standard-output*)) + ((eq stream t) (setq stream *terminal-io*))) + (swank::presenting-object object stream + (write-unreadable-start object stream) + (when type + (princ (type-of object) stream) + (stream-write-char stream #\space)) + (when thunk + (funcall thunk)) + (if id + (%write-address object stream #\>) + (pp-end-block stream ">")) + nil)) + (defmethod print-object :around ((pathname pathname) stream) + (swank::presenting-object-if + (swank::can-present-readable-objects stream) + pathname stream (call-next-method)))) + (ccl::def-load-pointers clear-presentations () + (swank::clear-presentation-tables))) + +(in-package :swank) + +#+cmu +(progn + (fwrappers:define-fwrapper presenting-unreadable-wrapper (object stream type identity body) + (presenting-object object stream + (fwrappers:call-next-function))) + + (fwrappers:define-fwrapper presenting-pathname-wrapper (pathname stream depth) + (presenting-object-if (can-present-readable-objects stream) pathname stream + (fwrappers:call-next-function))) + + (defun monkey-patch-stream-printing () + (fwrappers::fwrap 'lisp::%print-pathname #'presenting-pathname-wrapper) + (fwrappers::fwrap 'lisp::%print-unreadable-object #'presenting-unreadable-wrapper))) + +#+sbcl +(progn + (defvar *saved-%print-unreadable-object* + (fdefinition 'sb-impl::%print-unreadable-object)) + + (defun monkey-patch-stream-printing () + (sb-ext:without-package-locks + (when (eq (fdefinition 'sb-impl::%print-unreadable-object) + *saved-%print-unreadable-object*) + (setf (fdefinition 'sb-impl::%print-unreadable-object) + (lambda (object stream type identity &optional body) + (presenting-object object stream + (funcall *saved-%print-unreadable-object* + object stream type identity body))))) + (defmethod print-object :around ((object pathname) stream) + (presenting-object object stream + (call-next-method)))))) + +#+allegro +(progn + (excl:def-fwrapper presenting-unreadable-wrapper (object stream type identity continuation) + (swank::presenting-object object stream (excl:call-next-fwrapper))) + (excl:def-fwrapper presenting-pathname-wrapper (pathname stream depth) + (presenting-object-if (can-present-readable-objects stream) pathname stream + (excl:call-next-fwrapper))) + (defun monkey-patch-stream-printing () + (excl:fwrap 'excl::print-unreadable-object-1 + 'print-unreadable-present 'presenting-unreadable-wrapper) + (excl:fwrap 'excl::pathname-printer + 'print-pathname-present 'presenting-pathname-wrapper))) + +#-(or allegro sbcl cmu openmcl) +(defun monkey-patch-stream-printing () + (values)) + +;; Hook into SWANK. + +(defslimefun init-presentation-streams () + (monkey-patch-stream-printing) + ;; FIXME: import/use swank-repl to avoid package qualifier. + (setq swank-repl:*send-repl-results-function* + 'present-repl-results-via-presentation-streams)) + +(provide :swank-presentation-streams) diff --git a/vim/bundle/slimv/slime/contrib/swank-presentations.lisp b/vim/bundle/slimv/slime/contrib/swank-presentations.lisp new file mode 100644 index 0000000..11326af --- /dev/null +++ b/vim/bundle/slimv/slime/contrib/swank-presentations.lisp @@ -0,0 +1,246 @@ +;;; swank-presentations.lisp --- imitate LispM's presentations +;; +;; Authors: Alan Ruttenberg <alanr-l@mumble.net> +;; Luke Gorrie <luke@synap.se> +;; Helmut Eller <heller@common-lisp.net> +;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> +;; +;; License: This code has been placed in the Public Domain. All warranties +;; are disclaimed. +;; + +(in-package :swank) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (swank-require :swank-repl)) + +;;;; Recording and accessing results of computations + +(defvar *record-repl-results* t + "Non-nil means that REPL results are saved for later lookup.") + +(defvar *object-to-presentation-id* + (make-weak-key-hash-table :test 'eq) + "Store the mapping of objects to numeric identifiers") + +(defvar *presentation-id-to-object* + (make-weak-value-hash-table :test 'eql) + "Store the mapping of numeric identifiers to objects") + +(defun clear-presentation-tables () + (clrhash *object-to-presentation-id*) + (clrhash *presentation-id-to-object*)) + +(defvar *presentation-counter* 0 "identifier counter") + +(defvar *nil-surrogate* (make-symbol "nil-surrogate")) + +;; XXX thread safety? [2006-09-13] mb: not in the slightest (fwiw the +;; rest of slime isn't thread safe either), do we really care? +(defun save-presented-object (object) + "Save OBJECT and return the assigned id. +If OBJECT was saved previously return the old id." + (let ((object (if (null object) *nil-surrogate* object))) + ;; We store *nil-surrogate* instead of nil, to distinguish it from + ;; an object that was garbage collected. + (or (gethash object *object-to-presentation-id*) + (let ((id (incf *presentation-counter*))) + (setf (gethash id *presentation-id-to-object*) object) + (setf (gethash object *object-to-presentation-id*) id) + id)))) + +(defslimefun lookup-presented-object (id) + "Retrieve the object corresponding to ID. +The secondary value indicates the absence of an entry." + (etypecase id + (integer + ;; + (multiple-value-bind (object foundp) + (gethash id *presentation-id-to-object*) + (cond + ((eql object *nil-surrogate*) + ;; A stored nil object + (values nil t)) + ((null object) + ;; Object that was replaced by nil in the weak hash table + ;; when the object was garbage collected. + (values nil nil)) + (t + (values object foundp))))) + (cons + (dcase id + ((:frame-var thread-id frame index) + (declare (ignore thread-id)) ; later + (handler-case + (frame-var-value frame index) + (t (condition) + (declare (ignore condition)) + (values nil nil)) + (:no-error (value) + (values value t)))) + ((:inspected-part part-index) + (inspector-nth-part part-index)))))) + +(defslimefun lookup-presented-object-or-lose (id) + "Get the result of the previous REPL evaluation with ID." + (multiple-value-bind (object foundp) (lookup-presented-object id) + (cond (foundp object) + (t (error "Attempt to access unrecorded object (id ~D)." id))))) + +(defslimefun lookup-and-save-presented-object-or-lose (id) + "Get the object associated with ID and save it in the presentation tables." + (let ((obj (lookup-presented-object-or-lose id))) + (save-presented-object obj))) + +(defslimefun clear-repl-results () + "Forget the results of all previous REPL evaluations." + (clear-presentation-tables) + t) + +(defun present-repl-results (values) + ;; Override a function in swank.lisp, so that + ;; presentations are associated with every REPL result. + (flet ((send (value) + (let ((id (and *record-repl-results* + (save-presented-object value)))) + (send-to-emacs `(:presentation-start ,id :repl-result)) + (send-to-emacs `(:write-string ,(prin1-to-string value) + :repl-result)) + (send-to-emacs `(:presentation-end ,id :repl-result)) + (send-to-emacs `(:write-string ,(string #\Newline) + :repl-result))))) + (fresh-line) + (finish-output) + (if (null values) + (send-to-emacs `(:write-string "; No value" :repl-result)) + (mapc #'send values)))) + + +;;;; Presentation menu protocol +;; +;; To define a menu for a type of object, define a method +;; menu-choices-for-presentation on that object type. This function +;; should return a list of two element lists where the first element is +;; the name of the menu action and the second is a function that will be +;; called if the menu is chosen. The function will be called with 3 +;; arguments: +;; +;; choice: The string naming the action from above +;; +;; object: The object +;; +;; id: The presentation id of the object +;; +;; You might want append (when (next-method-p) (call-next-method)) to +;; pick up the Menu actions of superclasses. +;; + +(defvar *presentation-active-menu* nil) + +(defun menu-choices-for-presentation-id (id) + (multiple-value-bind (ob presentp) (lookup-presented-object id) + (cond ((not presentp) 'not-present) + (t + (let ((menu-and-actions (menu-choices-for-presentation ob))) + (setq *presentation-active-menu* (cons id menu-and-actions)) + (mapcar 'car menu-and-actions)))))) + +(defun swank-ioify (thing) + (cond ((keywordp thing) thing) + ((and (symbolp thing)(not (find #\: (symbol-name thing)))) + (intern (symbol-name thing) 'swank-io-package)) + ((consp thing) (cons (swank-ioify (car thing)) + (swank-ioify (cdr thing)))) + (t thing))) + +(defun execute-menu-choice-for-presentation-id (id count item) + (let ((ob (lookup-presented-object id))) + (assert (equal id (car *presentation-active-menu*)) () + "Bug: Execute menu call for id ~a but menu has id ~a" + id (car *presentation-active-menu*)) + (let ((action (second (nth (1- count) (cdr *presentation-active-menu*))))) + (swank-ioify (funcall action item ob id))))) + + +(defgeneric menu-choices-for-presentation (object) + (:method (ob) (declare (ignore ob)) nil)) ; default method + +;; Pathname +(defmethod menu-choices-for-presentation ((ob pathname)) + (let* ((file-exists (ignore-errors (probe-file ob))) + (lisp-type (make-pathname :type "lisp")) + (source-file (and (not (member (pathname-type ob) '("lisp" "cl") + :test 'equal)) + (let ((source (merge-pathnames lisp-type ob))) + (and (ignore-errors (probe-file source)) + source)))) + (fasl-file (and file-exists + (equal (ignore-errors + (namestring + (truename + (compile-file-pathname + (merge-pathnames lisp-type ob))))) + (namestring (truename ob)))))) + (remove nil + (list* + (and (and file-exists (not fasl-file)) + (list "Edit this file" + (lambda(choice object id) + (declare (ignore choice id)) + (ed-in-emacs (namestring (truename object))) + nil))) + (and file-exists + (list "Dired containing directory" + (lambda (choice object id) + (declare (ignore choice id)) + (ed-in-emacs (namestring + (truename + (merge-pathnames + (make-pathname :name "" :type "") + object)))) + nil))) + (and fasl-file + (list "Load this fasl file" + (lambda (choice object id) + (declare (ignore choice id object)) + (load ob) + nil))) + (and fasl-file + (list "Delete this fasl file" + (lambda (choice object id) + (declare (ignore choice id object)) + (let ((nt (namestring (truename ob)))) + (when (y-or-n-p-in-emacs "Delete ~a? " nt) + (delete-file nt))) + nil))) + (and source-file + (list "Edit lisp source file" + (lambda (choice object id) + (declare (ignore choice id object)) + (ed-in-emacs (namestring (truename source-file))) + nil))) + (and source-file + (list "Load lisp source file" + (lambda(choice object id) + (declare (ignore choice id object)) + (load source-file) + nil))) + (and (next-method-p) (call-next-method)))))) + +(defmethod menu-choices-for-presentation ((ob function)) + (list (list "Disassemble" + (lambda (choice object id) + (declare (ignore choice id)) + (disassemble object))))) + +(defslimefun inspect-presentation (id reset-p) + (let ((what (lookup-presented-object-or-lose id))) + (when reset-p + (reset-inspector)) + (inspect-object what))) + +(defslimefun init-presentations () + ;; FIXME: import/use swank-repl to avoid package qualifier. + (setq swank-repl:*send-repl-results-function* 'present-repl-results)) + +(provide :swank-presentations) diff --git a/vim/bundle/slimv/slime/contrib/swank-quicklisp.lisp b/vim/bundle/slimv/slime/contrib/swank-quicklisp.lisp new file mode 100644 index 0000000..3654599 --- /dev/null +++ b/vim/bundle/slimv/slime/contrib/swank-quicklisp.lisp @@ -0,0 +1,17 @@ +;;; swank-quicklisp.lisp -- Quicklisp support +;; +;; Authors: Matthew Kennedy <burnsidemk@gmail.com> +;; License: Public Domain +;; + +(in-package :swank) + +(defslimefun list-quicklisp-systems () + "Returns the Quicklisp systems list." + (if (member :quicklisp *features*) + (let ((ql-dist-name (find-symbol "NAME" "QL-DIST")) + (ql-system-list (find-symbol "SYSTEM-LIST" "QL"))) + (mapcar ql-dist-name (funcall ql-system-list))) + (error "Could not find Quicklisp already loaded."))) + +(provide :swank-quicklisp) diff --git a/vim/bundle/slimv/slime/contrib/swank-r6rs.scm b/vim/bundle/slimv/slime/contrib/swank-r6rs.scm new file mode 100644 index 0000000..4e48050 --- /dev/null +++ b/vim/bundle/slimv/slime/contrib/swank-r6rs.scm @@ -0,0 +1,416 @@ +;; swank-r6rs.sls --- Shareable code between swank-ikarus and swank-larceny +;; +;; Licence: public domain +;; Author: Helmut Eller +;; +;; This is a Swank server barely capable enough to process simple eval +;; requests from Emacs before dying. No fancy features like +;; backtraces, module redefintion, M-. etc. are implemented. Don't +;; even think about pc-to-source mapping. +;; +;; Despite standard modules, this file uses (swank os) and (swank sys) +;; which define implementation dependend functionality. There are +;; multiple modules in this files, which is probably not standardized. +;; + +;; Naive FORMAT implementation which supports: ~a ~s ~d ~x ~c +(library (swank format) + (export format printf fprintf) + (import (rnrs)) + + (define (format f . args) + (call-with-string-output-port + (lambda (port) (apply fprintf port f args)))) + + (define (printf f . args) + (let ((port (current-output-port))) + (apply fprintf port f args) + (flush-output-port port))) + + (define (fprintf port f . args) + (let ((len (string-length f))) + (let loop ((i 0) (args args)) + (cond ((= i len) (assert (null? args))) + ((and (char=? (string-ref f i) #\~) + (< (+ i 1) len)) + (dispatch-format (string-ref f (+ i 1)) port (car args)) + (loop (+ i 2) (cdr args))) + (else + (put-char port (string-ref f i)) + (loop (+ i 1) args)))))) + + (define (dispatch-format char port arg) + (let ((probe (assoc char format-dispatch-table))) + (cond (probe ((cdr probe) arg port)) + (else (error "invalid format char: " char))))) + + (define format-dispatch-table + `((#\a . ,display) + (#\s . ,write) + (#\d . ,(lambda (arg port) (put-string port (number->string arg 10)))) + (#\x . ,(lambda (arg port) (put-string port (number->string arg 16)))) + (#\c . ,(lambda (arg port) (put-char port arg)))))) + + +;; CL-style restarts to let us continue after errors. +(library (swank restarts) + (export with-simple-restart compute-restarts invoke-restart restart-name + write-restart-report) + (import (rnrs)) + + (define *restarts* '()) + + (define-record-type restart + (fields name reporter continuation)) + + (define (with-simple-restart name reporter thunk) + (call/cc + (lambda (k) + (let ((old-restarts *restarts*) + (restart (make-restart name (coerce-to-reporter reporter) k))) + (dynamic-wind + (lambda () (set! *restarts* (cons restart old-restarts))) + thunk + (lambda () (set! *restarts* old-restarts))))))) + + (define (compute-restarts) *restarts*) + + (define (invoke-restart restart . args) + (apply (restart-continuation restart) args)) + + (define (write-restart-report restart port) + ((restart-reporter restart) port)) + + (define (coerce-to-reporter obj) + (cond ((string? obj) (lambda (port) (put-string port obj))) + (#t (assert (procedure? obj)) obj))) + + ) + +;; This module encodes & decodes messages from the wire and queues them. +(library (swank event-queue) + (export make-event-queue wait-for-event enqueue-event + read-event write-event) + (import (rnrs) + (rnrs mutable-pairs) + (swank format)) + + (define-record-type event-queue + (fields (mutable q) wait-fun) + (protocol (lambda (init) + (lambda (wait-fun) + (init '() wait-fun))))) + + (define (wait-for-event q pattern) + (or (poll q pattern) + (begin + ((event-queue-wait-fun q) q) + (wait-for-event q pattern)))) + + (define (poll q pattern) + (let loop ((lag #f) + (l (event-queue-q q))) + (cond ((null? l) #f) + ((event-match? (car l) pattern) + (cond (lag + (set-cdr! lag (cdr l)) + (car l)) + (else + (event-queue-q-set! q (cdr l)) + (car l)))) + (else (loop l (cdr l)))))) + + (define (event-match? event pattern) + (cond ((or (number? pattern) + (member pattern '(t nil))) + (equal? event pattern)) + ((symbol? pattern) #t) + ((pair? pattern) + (case (car pattern) + ((quote) (equal? event (cadr pattern))) + ((or) (exists (lambda (p) (event-match? event p)) (cdr pattern))) + (else (and (pair? event) + (event-match? (car event) (car pattern)) + (event-match? (cdr event) (cdr pattern)))))) + (else (error "Invalid pattern: " pattern)))) + + (define (enqueue-event q event) + (event-queue-q-set! q + (append (event-queue-q q) + (list event)))) + + (define (write-event event port) + (let ((payload (call-with-string-output-port + (lambda (port) (write event port))))) + (write-length (string-length payload) port) + (put-string port payload) + (flush-output-port port))) + + (define (write-length len port) + (do ((i 24 (- i 4))) + ((= i 0)) + (put-string port + (number->string (bitwise-bit-field len (- i 4) i) + 16)))) + + (define (read-event port) + (let* ((header (string-append (get-string-n port 2) + (get-string-n port 2) + (get-string-n port 2))) + (_ (printf "header: ~s\n" header)) + (len (string->number header 16)) + (_ (printf "len: ~s\n" len)) + (payload (get-string-n port len))) + (printf "payload: ~s\n" payload) + (read (open-string-input-port payload)))) + + ) + +;; Entry points for SLIME commands. +(library (swank rpc) + (export connection-info interactive-eval + ;;compile-string-for-emacs + throw-to-toplevel sldb-abort + operator-arglist buffer-first-change + create-repl listener-eval) + (import (rnrs) + (rnrs eval) + (only (rnrs r5rs) scheme-report-environment) + (swank os) + (swank format) + (swank restarts) + (swank sys) + ) + + (define (connection-info . _) + `(,@'() + :pid ,(getpid) + :package (:name ">" :prompt ">") + :lisp-implementation (,@'() + :name ,(implementation-name) + :type "R6RS-Scheme"))) + + (define (interactive-eval string) + (call-with-values + (lambda () + (eval-in-interaction-environment (read-from-string string))) + (case-lambda + (() "; no value") + ((value) (format "~s" value)) + (values (format "values: ~s" values))))) + + (define (throw-to-toplevel) (invoke-restart-by-name-or-nil 'toplevel)) + + (define (sldb-abort) (invoke-restart-by-name-or-nil 'abort)) + + (define (invoke-restart-by-name-or-nil name) + (let ((r (find (lambda (r) (eq? (restart-name r) name)) + (compute-restarts)))) + (if r (invoke-restart r) 'nil))) + + (define (create-repl target) + (list "" "")) + + (define (listener-eval string) + (call-with-values (lambda () (eval-region string)) + (lambda values `(:values ,@(map (lambda (v) (format "~s" v)) values))))) + + (define (eval-region string) + (let ((sexp (read-from-string string))) + (if (eof-object? exp) + (values) + (eval-in-interaction-environment sexp)))) + + (define (read-from-string string) + (call-with-port (open-string-input-port string) read)) + + (define (operator-arglist . _) 'nil) + (define (buffer-first-change . _) 'nil) + + ) + +;; The server proper. Does the TCP stuff and exception handling. +(library (swank) + (export start-server) + (import (rnrs) + (rnrs eval) + (swank os) + (swank format) + (swank event-queue) + (swank restarts)) + + (define-record-type connection + (fields in-port out-port event-queue)) + + (define (start-server port) + (accept-connections (or port 4005) #f)) + + (define (start-server/port-file port-file) + (accept-connections #f port-file)) + + (define (accept-connections port port-file) + (let ((sock (make-server-socket port))) + (printf "Listening on port: ~s\n" (local-port sock)) + (when port-file + (write-port-file (local-port sock) port-file)) + (let-values (((in out) (accept sock (latin-1-codec)))) + (dynamic-wind + (lambda () #f) + (lambda () + (close-socket sock) + (serve in out)) + (lambda () + (close-port in) + (close-port out)))))) + + (define (write-port-file port port-file) + (call-with-output-file + (lambda (file) + (write port file)))) + + (define (serve in out) + (let ((err (current-error-port)) + (q (make-event-queue + (lambda (q) + (let ((e (read-event in))) + (printf "read: ~s\n" e) + (enqueue-event q e)))))) + (dispatch-loop (make-connection in out q)))) + + (define-record-type sldb-state + (fields level condition continuation next)) + + (define (dispatch-loop conn) + (let ((event (wait-for-event (connection-event-queue conn) 'x))) + (case (car event) + ((:emacs-rex) + (with-simple-restart + 'toplevel "Return to SLIME's toplevel" + (lambda () + (apply emacs-rex conn #f (cdr event))))) + (else (error "Unhandled event: ~s" event)))) + (dispatch-loop conn)) + + (define (recover thunk on-error-thunk) + (let ((ok #f)) + (dynamic-wind + (lambda () #f) + (lambda () + (call-with-values thunk + (lambda vals + (set! ok #t) + (apply values vals)))) + (lambda () + (unless ok + (on-error-thunk)))))) + + ;; Couldn't resist to exploit the prefix feature. + (define rpc-entries (environment '(prefix (swank rpc) swank:))) + + (define (emacs-rex conn sldb-state form package thread tag) + (let ((out (connection-out-port conn))) + (recover + (lambda () + (with-exception-handler + (lambda (condition) + (call/cc + (lambda (k) + (sldb-exception-handler conn condition k sldb-state)))) + (lambda () + (let ((value (apply (eval (car form) rpc-entries) (cdr form)))) + (write-event `(:return (:ok ,value) ,tag) out))))) + (lambda () + (write-event `(:return (:abort) ,tag) out))))) + + (define (sldb-exception-handler connection condition k sldb-state) + (when (serious-condition? condition) + (let ((level (if sldb-state (+ (sldb-state-level sldb-state) 1) 1)) + (out (connection-out-port connection))) + (write-event `(:debug 0 ,level ,@(debugger-info condition connection)) + out) + (dynamic-wind + (lambda () #f) + (lambda () + (sldb-loop connection + (make-sldb-state level condition k sldb-state))) + (lambda () (write-event `(:debug-return 0 ,level nil) out)))))) + + (define (sldb-loop connection state) + (apply emacs-rex connection state + (cdr (wait-for-event (connection-event-queue connection) + '(':emacs-rex . _)))) + (sldb-loop connection state)) + + (define (debugger-info condition connection) + (list `(,(call-with-string-output-port + (lambda (port) (print-condition condition port))) + ,(format " [type ~s]" (if (record? condition) + (record-type-name (record-rtd condition)) + )) + ()) + (map (lambda (r) + (list (format "~a" (restart-name r)) + (call-with-string-output-port + (lambda (port) + (write-restart-report r port))))) + (compute-restarts)) + '() + '())) + + (define (print-condition obj port) + (cond ((condition? obj) + (let ((list (simple-conditions obj))) + (case (length list) + ((0) + (display "Compuond condition with zero components" port)) + ((1) + (assert (eq? obj (car list))) + (print-simple-condition (car list) port)) + (else + (display "Compound condition:\n" port) + (for-each (lambda (c) + (display " " port) + (print-simple-condition c port) + (newline port)) + list))))) + (#t + (fprintf port "Non-condition object: ~s" obj)))) + + (define (print-simple-condition condition port) + (fprintf port "~a" (record-type-name (record-rtd condition))) + (case (count-record-fields condition) + ((0) #f) + ((1) + (fprintf port ": ") + (do-record-fields condition (lambda (name value) (write value port)))) + (else + (fprintf port ":") + (do-record-fields condition (lambda (name value) + (fprintf port "\n~a: ~s" name value)))))) + + ;; Call FUN with RECORD's rtd and parent rtds. + (define (do-record-rtds record fun) + (do ((rtd (record-rtd record) (record-type-parent rtd))) + ((not rtd)) + (fun rtd))) + + ;; Call FUN with RECORD's field names and values. + (define (do-record-fields record fun) + (do-record-rtds + record + (lambda (rtd) + (let* ((names (record-type-field-names rtd)) + (len (vector-length names))) + (do ((i 0 (+ 1 i))) + ((= i len)) + (fun (vector-ref names i) ((record-accessor rtd i) record))))))) + + ;; Return the number of fields in RECORD + (define (count-record-fields record) + (let ((i 0)) + (do-record-rtds + record (lambda (rtd) + (set! i (+ i (vector-length (record-type-field-names rtd)))))) + i)) + + ) diff --git a/vim/bundle/slimv/slime/contrib/swank-repl.lisp b/vim/bundle/slimv/slime/contrib/swank-repl.lisp new file mode 100644 index 0000000..0bed5f4 --- /dev/null +++ b/vim/bundle/slimv/slime/contrib/swank-repl.lisp @@ -0,0 +1,450 @@ +;;; swank-repl.lisp --- Server side part of the Lisp listener. +;; +;; License: public domain +(in-package swank) + +(defpackage swank-repl + (:use cl swank/backend) + (:export *send-repl-results-function*) + (:import-from + swank + + *default-worker-thread-bindings* + + *loopback-interface* + + add-hook + *connection-closed-hook* + + eval-region + with-buffer-syntax + + connection + connection.socket-io + connection.repl-results + connection.user-input + connection.user-output + connection.user-io + connection.trace-output + connection.dedicated-output + connection.env + + multithreaded-connection + mconn.active-threads + mconn.repl-thread + mconn.auto-flush-thread + use-threads-p + + *emacs-connection* + default-connection + with-connection + + send-to-emacs + *communication-style* + handle-requests + wait-for-event + make-tag + thread-for-evaluation + socket-quest + + authenticate-client + encode-message + + auto-flush-loop + clear-user-input + + current-thread-id + cat + with-struct* + with-retry-restart + with-bindings + + package-string-for-prompt + find-external-format-or-lose + + defslimefun + + ;; FIXME: those should be exported from swank-repl only, but how to + ;; do that whithout breaking init files? + *use-dedicated-output-stream* + *dedicated-output-stream-port* + *globally-redirect-io* + + )) + +(in-package swank-repl) + +(defvar *use-dedicated-output-stream* nil + "When T swank will attempt to create a second connection to Emacs +which is used just to send output.") + +(defvar *dedicated-output-stream-port* 0 + "Which port we should use for the dedicated output stream.") + +(defvar *dedicated-output-stream-buffering* + (if (eq *communication-style* :spawn) t nil) + "The buffering scheme that should be used for the output stream. +Valid values are nil, t, :line") + +(defvar *globally-redirect-io* nil + "When non-nil globally redirect all standard streams to Emacs.") + +(defun open-streams (connection properties) + "Return the 5 streams for IO redirection: +DEDICATED-OUTPUT INPUT OUTPUT IO REPL-RESULTS" + (let* ((input-fn + (lambda () + (with-connection (connection) + (with-simple-restart (abort-read + "Abort reading input from Emacs.") + (read-user-input-from-emacs))))) + (dedicated-output (if *use-dedicated-output-stream* + (open-dedicated-output-stream + connection + (getf properties :coding-system)))) + (in (make-input-stream input-fn)) + (out (or dedicated-output + (make-output-stream (make-output-function connection)))) + (io (make-two-way-stream in out)) + (repl-results (make-output-stream-for-target connection + :repl-result))) + (typecase connection + (multithreaded-connection + (setf (mconn.auto-flush-thread connection) + (spawn (lambda () (auto-flush-loop out)) + :name "auto-flush-thread")))) + (values dedicated-output in out io repl-results))) + +(defun make-output-function (connection) + "Create function to send user output to Emacs." + (lambda (string) + (with-connection (connection) + (send-to-emacs `(:write-string ,string))))) + +(defun make-output-function-for-target (connection target) + "Create a function to send user output to a specific TARGET in Emacs." + (lambda (string) + (with-connection (connection) + (with-simple-restart + (abort "Abort sending output to Emacs.") + (send-to-emacs `(:write-string ,string ,target)))))) + +(defun make-output-stream-for-target (connection target) + "Create a stream that sends output to a specific TARGET in Emacs." + (make-output-stream (make-output-function-for-target connection target))) + +(defun open-dedicated-output-stream (connection coding-system) + "Open a dedicated output connection to the Emacs on SOCKET-IO. +Return an output stream suitable for writing program output. + +This is an optimized way for Lisp to deliver output to Emacs." + (let ((socket (socket-quest *dedicated-output-stream-port* nil)) + (ef (find-external-format-or-lose coding-system))) + (unwind-protect + (let ((port (local-port socket))) + (encode-message `(:open-dedicated-output-stream ,port + ,coding-system) + (connection.socket-io connection)) + (let ((dedicated (accept-connection + socket + :external-format ef + :buffering *dedicated-output-stream-buffering* + :timeout 30))) + (authenticate-client dedicated) + (close-socket socket) + (setf socket nil) + dedicated)) + (when socket + (close-socket socket))))) + +(defmethod thread-for-evaluation ((connection multithreaded-connection) + (id (eql :find-existing))) + (or (car (mconn.active-threads connection)) + (find-repl-thread connection))) + +(defmethod thread-for-evaluation ((connection multithreaded-connection) + (id (eql :repl-thread))) + (find-repl-thread connection)) + +(defun find-repl-thread (connection) + (cond ((not (use-threads-p)) + (current-thread)) + (t + (let ((thread (mconn.repl-thread connection))) + (cond ((not thread) nil) + ((thread-alive-p thread) thread) + (t + (setf (mconn.repl-thread connection) + (spawn-repl-thread connection "new-repl-thread")))))))) + +(defun spawn-repl-thread (connection name) + (spawn (lambda () + (with-bindings *default-worker-thread-bindings* + (repl-loop connection))) + :name name)) + +(defun repl-loop (connection) + (handle-requests connection)) + +;;;;; Redirection during requests +;;; +;;; We always redirect the standard streams to Emacs while evaluating +;;; an RPC. This is done with simple dynamic bindings. + +(defslimefun create-repl (target &key coding-system) + (assert (eq target nil)) + (let ((conn *emacs-connection*)) + (initialize-streams-for-connection conn `(:coding-system ,coding-system)) + (with-struct* (connection. @ conn) + (setf (@ env) + `((*standard-input* . ,(@ user-input)) + ,@(unless *globally-redirect-io* + `((*standard-output* . ,(@ user-output)) + (*trace-output* . ,(or (@ trace-output) (@ user-output))) + (*error-output* . ,(@ user-output)) + (*debug-io* . ,(@ user-io)) + (*query-io* . ,(@ user-io)) + (*terminal-io* . ,(@ user-io)))))) + (maybe-redirect-global-io conn) + (add-hook *connection-closed-hook* 'update-redirection-after-close) + (typecase conn + (multithreaded-connection + (setf (mconn.repl-thread conn) + (spawn-repl-thread conn "repl-thread")))) + (list (package-name *package*) + (package-string-for-prompt *package*))))) + +(defun initialize-streams-for-connection (connection properties) + (multiple-value-bind (dedicated in out io repl-results) + (open-streams connection properties) + (setf (connection.dedicated-output connection) dedicated + (connection.user-io connection) io + (connection.user-output connection) out + (connection.user-input connection) in + (connection.repl-results connection) repl-results) + connection)) + +(defun read-user-input-from-emacs () + (let ((tag (make-tag))) + (force-output) + (send-to-emacs `(:read-string ,(current-thread-id) ,tag)) + (let ((ok nil)) + (unwind-protect + (prog1 (caddr (wait-for-event `(:emacs-return-string ,tag value))) + (setq ok t)) + (unless ok + (send-to-emacs `(:read-aborted ,(current-thread-id) ,tag))))))) + +;;;;; Listener eval + +(defvar *listener-eval-function* 'repl-eval) + +(defvar *listener-saved-value* nil) + +(defslimefun listener-save-value (slimefun &rest args) + "Apply SLIMEFUN to ARGS and save the value. +The saved value should be visible to all threads and retrieved via +LISTENER-GET-VALUE." + (setq *listener-saved-value* (apply slimefun args)) + t) + +(defslimefun listener-get-value () + "Get the last value saved by LISTENER-SAVE-VALUE. +The value should be produced as if it were requested through +LISTENER-EVAL directly, so that spacial variables *, etc are set." + (listener-eval (let ((*package* (find-package :keyword))) + (write-to-string '*listener-saved-value*)))) + +(defslimefun listener-eval (string &key (window-width nil window-width-p)) + (if window-width-p + (let ((*print-right-margin* window-width)) + (funcall *listener-eval-function* string)) + (funcall *listener-eval-function* string))) + +(defslimefun clear-repl-variables () + (let ((variables '(*** ** * /// // / +++ ++ +))) + (loop for variable in variables + do (setf (symbol-value variable) nil)))) + +(defvar *send-repl-results-function* 'send-repl-results-to-emacs) + +(defun repl-eval (string) + (clear-user-input) + (with-buffer-syntax () + (with-retry-restart (:msg "Retry SLIME REPL evaluation request.") + (track-package + (lambda () + (multiple-value-bind (values last-form) (eval-region string) + (setq *** ** ** * * (car values) + /// // // / / values + +++ ++ ++ + + last-form) + (funcall *send-repl-results-function* values)))))) + nil) + +(defun track-package (fun) + (let ((p *package*)) + (unwind-protect (funcall fun) + (unless (eq *package* p) + (send-to-emacs (list :new-package (package-name *package*) + (package-string-for-prompt *package*))))))) + +(defun send-repl-results-to-emacs (values) + (finish-output) + (if (null values) + (send-to-emacs `(:write-string "; No value" :repl-result)) + (dolist (v values) + (send-to-emacs `(:write-string ,(cat (prin1-to-string v) #\newline) + :repl-result))))) + +(defslimefun redirect-trace-output (target) + (setf (connection.trace-output *emacs-connection*) + (make-output-stream-for-target *emacs-connection* target)) + nil) + + + +;;;; IO to Emacs +;;; +;;; This code handles redirection of the standard I/O streams +;;; (`*standard-output*', etc) into Emacs. The `connection' structure +;;; contains the appropriate streams, so all we have to do is make the +;;; right bindings. + +;;;;; Global I/O redirection framework +;;; +;;; Optionally, the top-level global bindings of the standard streams +;;; can be assigned to be redirected to Emacs. When Emacs connects we +;;; redirect the streams into the connection, and they keep going into +;;; that connection even if more are established. If the connection +;;; handling the streams closes then another is chosen, or if there +;;; are no connections then we revert to the original (real) streams. +;;; +;;; It is slightly tricky to assign the global values of standard +;;; streams because they are often shadowed by dynamic bindings. We +;;; solve this problem by introducing an extra indirection via synonym +;;; streams, so that *STANDARD-INPUT* is a synonym stream to +;;; *CURRENT-STANDARD-INPUT*, etc. We never shadow the "current" +;;; variables, so they can always be assigned to affect a global +;;; change. + +;;;;; Global redirection setup + +(defvar *saved-global-streams* '() + "A plist to save and restore redirected stream objects. +E.g. the value for '*standard-output* holds the stream object +for *standard-output* before we install our redirection.") + +(defun setup-stream-indirection (stream-var &optional stream) + "Setup redirection scaffolding for a global stream variable. +Supposing (for example) STREAM-VAR is *STANDARD-INPUT*, this macro: + +1. Saves the value of *STANDARD-INPUT* in `*SAVED-GLOBAL-STREAMS*'. + +2. Creates *CURRENT-STANDARD-INPUT*, initially with the same value as +*STANDARD-INPUT*. + +3. Assigns *STANDARD-INPUT* to a synonym stream pointing to +*CURRENT-STANDARD-INPUT*. + +This has the effect of making *CURRENT-STANDARD-INPUT* contain the +effective global value for *STANDARD-INPUT*. This way we can assign +the effective global value even when *STANDARD-INPUT* is shadowed by a +dynamic binding." + (let ((current-stream-var (prefixed-var '#:current stream-var)) + (stream (or stream (symbol-value stream-var)))) + ;; Save the real stream value for the future. + (setf (getf *saved-global-streams* stream-var) stream) + ;; Define a new variable for the effective stream. + ;; This can be reassigned. + (proclaim `(special ,current-stream-var)) + (set current-stream-var stream) + ;; Assign the real binding as a synonym for the current one. + (let ((stream (make-synonym-stream current-stream-var))) + (set stream-var stream) + (set-default-initial-binding stream-var `(quote ,stream))))) + +(defun prefixed-var (prefix variable-symbol) + "(PREFIXED-VAR \"FOO\" '*BAR*) => SWANK::*FOO-BAR*" + (let ((basename (subseq (symbol-name variable-symbol) 1))) + (intern (format nil "*~A-~A" (string prefix) basename) :swank))) + +(defvar *standard-output-streams* + '(*standard-output* *error-output* *trace-output*) + "The symbols naming standard output streams.") + +(defvar *standard-input-streams* + '(*standard-input*) + "The symbols naming standard input streams.") + +(defvar *standard-io-streams* + '(*debug-io* *query-io* *terminal-io*) + "The symbols naming standard io streams.") + +(defun init-global-stream-redirection () + (when *globally-redirect-io* + (cond (*saved-global-streams* + (warn "Streams already redirected.")) + (t + (mapc #'setup-stream-indirection + (append *standard-output-streams* + *standard-input-streams* + *standard-io-streams*)))))) + +(defun globally-redirect-io-to-connection (connection) + "Set the standard I/O streams to redirect to CONNECTION. +Assigns *CURRENT-<STREAM>* for all standard streams." + (dolist (o *standard-output-streams*) + (set (prefixed-var '#:current o) + (connection.user-output connection))) + ;; FIXME: If we redirect standard input to Emacs then we get the + ;; regular Lisp top-level trying to read from our REPL. + ;; + ;; Perhaps the ideal would be for the real top-level to run in a + ;; thread with local bindings for all the standard streams. Failing + ;; that we probably would like to inhibit it from reading while + ;; Emacs is connected. + ;; + ;; Meanwhile we just leave *standard-input* alone. + #+NIL + (dolist (i *standard-input-streams*) + (set (prefixed-var '#:current i) + (connection.user-input connection))) + (dolist (io *standard-io-streams*) + (set (prefixed-var '#:current io) + (connection.user-io connection)))) + +(defun revert-global-io-redirection () + "Set *CURRENT-<STREAM>* to *REAL-<STREAM>* for all standard streams." + (dolist (stream-var (append *standard-output-streams* + *standard-input-streams* + *standard-io-streams*)) + (set (prefixed-var '#:current stream-var) + (getf *saved-global-streams* stream-var)))) + +;;;;; Global redirection hooks + +(defvar *global-stdio-connection* nil + "The connection to which standard I/O streams are globally redirected. +NIL if streams are not globally redirected.") + +(defun maybe-redirect-global-io (connection) + "Consider globally redirecting to CONNECTION." + (when (and *globally-redirect-io* (null *global-stdio-connection*) + (connection.user-io connection)) + (unless *saved-global-streams* + (init-global-stream-redirection)) + (setq *global-stdio-connection* connection) + (globally-redirect-io-to-connection connection))) + +(defun update-redirection-after-close (closed-connection) + "Update redirection after a connection closes." + (check-type closed-connection connection) + (when (eq *global-stdio-connection* closed-connection) + (if (and (default-connection) *globally-redirect-io*) + ;; Redirect to another connection. + (globally-redirect-io-to-connection (default-connection)) + ;; No more connections, revert to the real streams. + (progn (revert-global-io-redirection) + (setq *global-stdio-connection* nil))))) + +(provide :swank-repl) diff --git a/vim/bundle/slimv/slime/contrib/swank-sbcl-exts.lisp b/vim/bundle/slimv/slime/contrib/swank-sbcl-exts.lisp new file mode 100644 index 0000000..29235cd --- /dev/null +++ b/vim/bundle/slimv/slime/contrib/swank-sbcl-exts.lisp @@ -0,0 +1,64 @@ +;;; swank-sbcl-exts.lisp --- Misc extensions for SBCL +;; +;; Authors: Tobias C. Rittweiler <tcr@freebits.de> +;; +;; License: Public Domain +;; + +(in-package :swank) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (swank-require :swank-arglists)) + +;; We need to do this so users can place `slime-sbcl-exts' into their +;; ~/.emacs, and still use any implementation they want. +#+sbcl +(progn + +;;; Display arglist of instructions. +;;; +(defmethod compute-enriched-decoded-arglist ((operator-form (eql 'sb-assem:inst)) + argument-forms) + (flet ((decode-instruction-arglist (instr-name instr-arglist) + (let ((decoded-arglist (decode-arglist instr-arglist))) + ;; The arglist of INST is (instruction ...INSTR-ARGLIST...). + (push 'sb-assem::instruction (arglist.required-args decoded-arglist)) + (values decoded-arglist + (list instr-name) + t)))) + (if (null argument-forms) + (call-next-method) + (destructuring-bind (instruction &rest args) argument-forms + (declare (ignore args)) + (let* ((instr-name + (typecase instruction + (arglist-dummy + (string-upcase (arglist-dummy.string-representation instruction))) + (symbol + (string-downcase instruction)))) + (instr-fn + #+#.(swank/backend:with-symbol 'inst-emitter-symbol 'sb-assem) + (sb-assem::inst-emitter-symbol instr-name) + #+(and + (not #.(swank/backend:with-symbol 'inst-emitter-symbol 'sb-assem)) + #.(swank/backend:with-symbol '*assem-instructions* 'sb-assem)) + (gethash instr-name sb-assem:*assem-instructions*))) + (cond ((not instr-fn) + (call-next-method)) + ((functionp instr-fn) + (with-available-arglist (arglist) (arglist instr-fn) + (decode-instruction-arglist instr-name arglist))) + (t + (assert (symbolp instr-fn)) + (with-available-arglist (arglist) (arglist instr-fn) + ;; SB-ASSEM:INST invokes a symbolic INSTR-FN with + ;; current segment and current vop implicitly. + (decode-instruction-arglist instr-name + (if (get instr-fn :macro) + arglist + (cddr arglist))))))))))) + + +) ; PROGN + +(provide :swank-sbcl-exts) diff --git a/vim/bundle/slimv/slime/contrib/swank-snapshot.lisp b/vim/bundle/slimv/slime/contrib/swank-snapshot.lisp new file mode 100644 index 0000000..8edb789 --- /dev/null +++ b/vim/bundle/slimv/slime/contrib/swank-snapshot.lisp @@ -0,0 +1,67 @@ + +(defpackage swank-snapshot + (:use cl) + (:export restore-snapshot save-snapshot background-save-snapshot) + (:import-from swank defslimefun)) +(in-package swank-snapshot) + +(defslimefun save-snapshot (image-file) + (swank/backend:save-image image-file + (let ((c swank::*emacs-connection*)) + (lambda () (resurrect c)))) + (format nil "Dumped lisp to ~A" image-file)) + +(defslimefun restore-snapshot (image-file) + (let* ((conn swank::*emacs-connection*) + (stream (swank::connection.socket-io conn)) + (clone (swank/backend:dup (swank/backend:socket-fd stream))) + (style (swank::connection.communication-style conn)) + (repl (if (swank::connection.user-io conn) t)) + (args (list "--swank-fd" (format nil "~d" clone) + "--swank-style" (format nil "~s" style) + "--swank-repl" (format nil "~s" repl)))) + (swank::close-connection conn nil nil) + (swank/backend:exec-image image-file args))) + +(defslimefun background-save-snapshot (image-file) + (let ((connection swank::*emacs-connection*)) + (flet ((complete (success) + (let ((swank::*emacs-connection* connection)) + (swank::background-message + "Dumping lisp image ~A ~:[failed!~;succeeded.~]" + image-file success))) + (awaken () + (resurrect connection))) + (swank/backend:background-save-image image-file + :restart-function #'awaken + :completion-function #'complete) + (format nil "Started dumping lisp to ~A..." image-file)))) + +(in-package :swank) + +(defun swank-snapshot::resurrect (old-connection) + (setq *log-output* nil) + (init-log-output) + (clear-event-history) + (setq *connections* (delete old-connection *connections*)) + (format *error-output* "args: ~s~%" (command-line-args)) + (let* ((fd (read-command-line-arg "--swank-fd")) + (style (read-command-line-arg "--swank-style")) + (repl (read-command-line-arg "--swank-repl")) + (* (format *error-output* "fd=~s style=~s~%" fd style)) + (stream (make-fd-stream fd nil)) + (connection (make-connection nil stream style))) + (let ((*emacs-connection* connection)) + (when repl (swank::create-repl nil)) + (background-message "~A" "Lisp image restored")) + (serve-requests connection) + (simple-repl))) + +(defun read-command-line-arg (name) + (let* ((args (command-line-args)) + (pos (position name args :test #'equal))) + (read-from-string (elt args (1+ pos))))) + +(in-package :swank-snapshot) + +(provide :swank-snapshot) diff --git a/vim/bundle/slimv/slime/contrib/swank-sprof.lisp b/vim/bundle/slimv/slime/contrib/swank-sprof.lisp new file mode 100644 index 0000000..675240f --- /dev/null +++ b/vim/bundle/slimv/slime/contrib/swank-sprof.lisp @@ -0,0 +1,154 @@ +;;; swank-sprof.lisp +;; +;; Authors: Juho Snellman +;; +;; License: MIT +;; + +(in-package :swank) + +#+sbcl +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :sb-sprof)) + +#+sbcl(progn + +(defvar *call-graph* nil) +(defvar *node-numbers* nil) +(defvar *number-nodes* nil) + +(defun frame-name (name) + (if (consp name) + (case (first name) + ((sb-c::xep sb-c::tl-xep + sb-c::&more-processor + sb-c::top-level-form + sb-c::&optional-processor) + (second name)) + (sb-pcl::fast-method + (cdr name)) + ((flet labels lambda) + (let* ((in (member :in name))) + (if (stringp (cadr in)) + (append (ldiff name in) (cddr in)) + name))) + (t + name)) + name)) + +(defun pretty-name (name) + (let ((*package* (find-package :common-lisp-user)) + (*print-right-margin* most-positive-fixnum)) + (format nil "~S" (frame-name name)))) + +(defun samples-percent (count) + (sb-sprof::samples-percent *call-graph* count)) + +(defun node-values (node) + (values (pretty-name (sb-sprof::node-name node)) + (samples-percent (sb-sprof::node-count node)) + (samples-percent (sb-sprof::node-accrued-count node)))) + +(defun filter-swank-nodes (nodes) + (let ((swank-packages (load-time-value + (mapcar #'find-package + '(swank swank/rpc swank/mop + swank/match swank/backend))))) + (remove-if (lambda (node) + (let ((name (sb-sprof::node-name node))) + (and (symbolp name) + (member (symbol-package name) swank-packages + :test #'eq)))) + nodes))) + +(defun serialize-call-graph (&key exclude-swank) + (let ((nodes (sb-sprof::call-graph-flat-nodes *call-graph*))) + (when exclude-swank + (setf nodes (filter-swank-nodes nodes))) + (setf nodes (sort (copy-list nodes) #'> + ;; :key #'sb-sprof::node-count))) + :key #'sb-sprof::node-accrued-count)) + (setf *number-nodes* (make-hash-table)) + (setf *node-numbers* (make-hash-table)) + (loop for node in nodes + for i from 1 + with total = 0 + collect (multiple-value-bind (name self cumulative) + (node-values node) + (setf (gethash node *node-numbers*) i + (gethash i *number-nodes*) node) + (incf total self) + (list i name self cumulative total)) into list + finally (return + (let ((rest (- 100 total))) + (return (append list + `((nil "Elsewhere" ,rest nil nil))))))))) + +(defslimefun swank-sprof-get-call-graph (&key exclude-swank) + (when (setf *call-graph* (sb-sprof:report :type nil)) + (serialize-call-graph :exclude-swank exclude-swank))) + +(defslimefun swank-sprof-expand-node (index) + (let* ((node (gethash index *number-nodes*))) + (labels ((caller-count (v) + (loop for e in (sb-sprof::vertex-edges v) do + (when (eq (sb-sprof::edge-vertex e) node) + (return-from caller-count (sb-sprof::call-count e)))) + 0) + (serialize-node (node count) + (etypecase node + (sb-sprof::cycle + (list (sb-sprof::cycle-index node) + (sb-sprof::cycle-name node) + (samples-percent count))) + (sb-sprof::node + (let ((name (node-values node))) + (list (gethash node *node-numbers*) + name + (samples-percent count))))))) + (list :callers (loop for node in + (sort (copy-list (sb-sprof::node-callers node)) #'> + :key #'caller-count) + collect (serialize-node node + (caller-count node))) + :calls (let ((edges (sort (copy-list (sb-sprof::vertex-edges node)) + #'> + :key #'sb-sprof::call-count))) + (loop for edge in edges + collect + (serialize-node (sb-sprof::edge-vertex edge) + (sb-sprof::call-count edge)))))))) + +(defslimefun swank-sprof-disassemble (index) + (let* ((node (gethash index *number-nodes*)) + (debug-info (sb-sprof::node-debug-info node))) + (with-output-to-string (s) + (typecase debug-info + (sb-impl::code-component + (sb-disassem::disassemble-memory (sb-vm::code-instructions debug-info) + (sb-vm::%code-code-size debug-info) + :stream s)) + (sb-di::compiled-debug-fun + (let ((component (sb-di::compiled-debug-fun-component debug-info))) + (sb-disassem::disassemble-code-component component :stream s))) + (t `(:error "No disassembly available")))))) + +(defslimefun swank-sprof-source-location (index) + (let* ((node (gethash index *number-nodes*)) + (debug-info (sb-sprof::node-debug-info node))) + (or (when (typep debug-info 'sb-di::compiled-debug-fun) + (let* ((component (sb-di::compiled-debug-fun-component debug-info)) + (function (sb-kernel::%code-entry-points component))) + (when function + (find-source-location function)))) + `(:error "No source location available")))) + +(defslimefun swank-sprof-start (&key (mode :cpu)) + (sb-sprof:start-profiling :mode mode)) + +(defslimefun swank-sprof-stop () + (sb-sprof:stop-profiling)) + +) + +(provide :swank-sprof) diff --git a/vim/bundle/slimv/slime/contrib/swank-trace-dialog.lisp b/vim/bundle/slimv/slime/contrib/swank-trace-dialog.lisp new file mode 100644 index 0000000..5cf95fd --- /dev/null +++ b/vim/bundle/slimv/slime/contrib/swank-trace-dialog.lisp @@ -0,0 +1,264 @@ +(defpackage :swank-trace-dialog + (:use :cl) + (:import-from :swank :defslimefun :from-string :to-string) + (:export #:clear-trace-tree + #:dialog-toggle-trace + #:dialog-trace + #:dialog-traced-p + #:dialog-untrace + #:dialog-untrace-all + #:inspect-trace-part + #:report-partial-tree + #:report-specs + #:report-total + #:report-trace-detail + #:report-specs + #:trace-format + #:still-inside + #:exited-non-locally + #:*record-backtrace* + #:*traces-per-report* + #:*dialog-trace-follows-trace* + #:find-trace-part + #:find-trace)) + +(in-package :swank-trace-dialog) + +(defparameter *record-backtrace* nil + "Record a backtrace of the last 20 calls for each trace. + +Beware that this may have a drastic performance impact on your +program.") + +(defparameter *traces-per-report* 150 + "Number of traces to report to emacs in each batch.") + + +;;;; `trace-entry' model +;;;; +(defvar *traces* (make-array 1000 :fill-pointer 0 + :adjustable t)) + +(defvar *trace-lock* (swank/backend:make-lock :name "swank-trace-dialog lock")) + +(defvar *current-trace-by-thread* (make-hash-table)) + +(defclass trace-entry () + ((id :reader id-of) + (children :accessor children-of :initform nil) + (backtrace :accessor backtrace-of :initform (when *record-backtrace* + (useful-backtrace))) + + (spec :initarg :spec :accessor spec-of + :initform (error "must provide a spec")) + (args :initarg :args :accessor args-of + :initform (error "must provide args")) + (parent :initarg :parent :reader parent-of + :initform (error "must provide a parent, even if nil")) + (retlist :initarg :retlist :accessor retlist-of + :initform 'still-inside))) + +(defmethod initialize-instance :after ((entry trace-entry) &rest initargs) + (declare (ignore initargs)) + (if (parent-of entry) + (nconc (children-of (parent-of entry)) (list entry))) + (swank/backend:call-with-lock-held + *trace-lock* + #'(lambda () + (setf (slot-value entry 'id) (fill-pointer *traces*)) + (vector-push-extend entry *traces*)))) + +(defmethod print-object ((entry trace-entry) stream) + (print-unreadable-object (entry stream) + (format stream "~a: ~a" (id-of entry) (spec-of entry)))) + +(defun completed-p (trace) (not (eq (retlist-of trace) 'still-inside))) + +(defun find-trace (id) + (when (<= 0 id (1- (length *traces*))) + (aref *traces* id))) + +(defun find-trace-part (id part-id type) + (let* ((trace (find-trace id)) + (l (and trace + (ecase type + (:arg (args-of trace)) + (:retval (swank::ensure-list (retlist-of trace))))))) + (values (nth part-id l) + (< part-id (length l))))) + +(defun useful-backtrace () + (swank/backend:call-with-debugging-environment + #'(lambda () + (loop for i from 0 + for frame in (swank/backend:compute-backtrace 0 20) + collect (list i (swank::frame-to-string frame)))))) + +(defun current-trace () + (gethash (swank/backend:current-thread) *current-trace-by-thread*)) + +(defun (setf current-trace) (trace) + (setf (gethash (swank/backend:current-thread) *current-trace-by-thread*) + trace)) + + +;;;; Control of traced specs +;;; +(defvar *traced-specs* '()) + +(defslimefun dialog-trace (spec) + (flet ((before-hook (args) + (setf (current-trace) (make-instance 'trace-entry + :spec spec + :args args + :parent (current-trace)))) + (after-hook (retlist) + (let ((trace (current-trace))) + (when trace + ;; the current trace might have been wiped away if the + ;; user cleared the tree in the meantime. no biggie, + ;; don't do anything. + ;; + (setf (retlist-of trace) retlist + (current-trace) (parent-of trace)))))) + (when (dialog-traced-p spec) + (warn "~a is apparently already traced! Untracing and retracing." spec) + (dialog-untrace spec)) + (swank/backend:wrap spec 'trace-dialog + :before #'before-hook + :after #'after-hook) + (pushnew spec *traced-specs*) + (format nil "~a is now traced for trace dialog" spec))) + +(defslimefun dialog-untrace (spec) + (swank/backend:unwrap spec 'trace-dialog) + (setq *traced-specs* (remove spec *traced-specs* :test #'equal)) + (format nil "~a is now untraced for trace dialog" spec)) + +(defslimefun dialog-toggle-trace (spec) + (if (dialog-traced-p spec) + (dialog-untrace spec) + (dialog-trace spec))) + +(defslimefun dialog-traced-p (spec) + (find spec *traced-specs* :test #'equal)) + +(defslimefun dialog-untrace-all () + (untrace) + (mapcar #'dialog-untrace *traced-specs*)) + +(defparameter *dialog-trace-follows-trace* nil) + +(setq swank:*after-toggle-trace-hook* + #'(lambda (spec traced-p) + (when *dialog-trace-follows-trace* + (cond (traced-p + (dialog-trace spec) + "traced for trace dialog as well") + (t + (dialog-untrace spec) + "untraced for the trace dialog as well"))))) + + +;;;; A special kind of trace call +;;; +(defun trace-format (format-spec &rest format-args) + "Make a string from FORMAT-SPEC and FORMAT-ARGS and as a trace." + (let* ((line (apply #'format nil format-spec format-args))) + (make-instance 'trace-entry :spec line + :args format-args + :parent (current-trace) + :retlist nil))) + + +;;;; Reporting to emacs +;;; +(defparameter *visitor-idx* 0) + +(defparameter *visitor-key* nil) + +(defvar *unfinished-traces* '()) + +(defun describe-trace-for-emacs (trace) + `(,(id-of trace) + ,(and (parent-of trace) (id-of (parent-of trace))) + ,(spec-of trace) + ,(loop for arg in (args-of trace) + for i from 0 + collect (list i (swank::to-line arg))) + ,(loop for retval in (swank::ensure-list (retlist-of trace)) + for i from 0 + collect (list i (swank::to-line retval))))) + +(defslimefun report-partial-tree (key) + (unless (equal key *visitor-key*) + (setq *visitor-idx* 0 + *visitor-key* key)) + (let* ((recently-finished + (loop with i = 0 + for trace in *unfinished-traces* + while (< i *traces-per-report*) + when (completed-p trace) + collect trace + and do + (incf i) + (setq *unfinished-traces* + (remove trace *unfinished-traces*)))) + (new (loop for i + from (length recently-finished) + below *traces-per-report* + while (< *visitor-idx* (length *traces*)) + for trace = (aref *traces* *visitor-idx*) + collect trace + unless (completed-p trace) + do (push trace *unfinished-traces*) + do (incf *visitor-idx*)))) + (list + (mapcar #'describe-trace-for-emacs + (append recently-finished new)) + (- (length *traces*) *visitor-idx*) + key))) + +(defslimefun report-trace-detail (trace-id) + (swank::call-with-bindings + swank::*inspector-printer-bindings* + #'(lambda () + (let ((trace (find-trace trace-id))) + (when trace + (append + (describe-trace-for-emacs trace) + (list (backtrace-of trace) + (swank::to-line trace)))))))) + +(defslimefun report-specs () + (sort (copy-list *traced-specs*) + #'string< + :key #'princ-to-string)) + +(defslimefun report-total () + (length *traces*)) + +(defslimefun clear-trace-tree () + (setf *current-trace-by-thread* (clrhash *current-trace-by-thread*) + *visitor-key* nil + *unfinished-traces* nil) + (swank/backend:call-with-lock-held + *trace-lock* + #'(lambda () (setf (fill-pointer *traces*) 0))) + nil) + +;; HACK: `swank::*inspector-history*' is unbound by default and needs +;; a reset in that case so that it won't error `swank::inspect-object' +;; before any other object is inspected in the slime session. +;; +(unless (boundp 'swank::*inspector-history*) + (swank::reset-inspector)) + +(defslimefun inspect-trace-part (trace-id part-id type) + (multiple-value-bind (obj found) + (find-trace-part trace-id part-id type) + (if found + (swank::inspect-object obj) + (error "No object found with ~a, ~a and ~a" trace-id part-id type)))) + +(provide :swank-trace-dialog) diff --git a/vim/bundle/slimv/slime/contrib/swank-util.lisp b/vim/bundle/slimv/slime/contrib/swank-util.lisp new file mode 100644 index 0000000..72743ba --- /dev/null +++ b/vim/bundle/slimv/slime/contrib/swank-util.lisp @@ -0,0 +1,63 @@ +;;; swank-util.lisp --- stuff of questionable utility +;; +;; License: public domain + +(in-package :swank) + +(defmacro do-symbols* ((var &optional (package '*package*) result-form) + &body body) + "Just like do-symbols, but makes sure a symbol is visited only once." + (let ((seen-ht (gensym "SEEN-HT"))) + `(let ((,seen-ht (make-hash-table :test #'eq))) + (do-symbols (,var ,package ,result-form) + (unless (gethash ,var ,seen-ht) + (setf (gethash ,var ,seen-ht) t) + (tagbody ,@body)))))) + +(defun classify-symbol (symbol) + "Returns a list of classifiers that classify SYMBOL according to its +underneath objects (e.g. :BOUNDP if SYMBOL constitutes a special +variable.) The list may contain the following classification +keywords: :BOUNDP, :FBOUNDP, :CONSTANT, :GENERIC-FUNCTION, +:TYPESPEC, :CLASS, :MACRO, :SPECIAL-OPERATOR, and/or :PACKAGE" + (check-type symbol symbol) + (flet ((type-specifier-p (s) + (or (documentation s 'type) + (not (eq (type-specifier-arglist s) :not-available))))) + (let (result) + (when (boundp symbol) (push (if (constantp symbol) + :constant :boundp) result)) + (when (fboundp symbol) (push :fboundp result)) + (when (type-specifier-p symbol) (push :typespec result)) + (when (find-class symbol nil) (push :class result)) + (when (macro-function symbol) (push :macro result)) + (when (special-operator-p symbol) (push :special-operator result)) + (when (find-package symbol) (push :package result)) + (when (and (fboundp symbol) + (typep (ignore-errors (fdefinition symbol)) + 'generic-function)) + (push :generic-function result)) + result))) + +(defun symbol-classification-string (symbol) + "Return a string in the form -f-c---- where each letter stands for +boundp fboundp generic-function class macro special-operator package" + (let ((letters "bfgctmsp") + (result (copy-seq "--------"))) + (flet ((flip (letter) + (setf (char result (position letter letters)) + letter))) + (when (boundp symbol) (flip #\b)) + (when (fboundp symbol) + (flip #\f) + (when (typep (ignore-errors (fdefinition symbol)) + 'generic-function) + (flip #\g))) + (when (type-specifier-p symbol) (flip #\t)) + (when (find-class symbol nil) (flip #\c) ) + (when (macro-function symbol) (flip #\m)) + (when (special-operator-p symbol) (flip #\s)) + (when (find-package symbol) (flip #\p)) + result))) + +(provide :swank-util) diff --git a/vim/bundle/slimv/slime/metering.lisp b/vim/bundle/slimv/slime/metering.lisp new file mode 100644 index 0000000..b87d280 --- /dev/null +++ b/vim/bundle/slimv/slime/metering.lisp @@ -0,0 +1,1213 @@ +;;; -*- Mode: LISP; Package: monitor; Syntax: Common-lisp; Base: 10.; -*- +;;; Tue Jan 25 18:32:28 1994 by Mark Kantrowitz <mkant@GLINDA.OZ.CS.CMU.EDU> + +;;; **************************************************************** +;;; Metering System ************************************************ +;;; **************************************************************** +;;; +;;; The Metering System is a portable Common Lisp code profiling tool. +;;; It gathers timing and consing statistics for specified functions +;;; while a program is running. +;;; +;;; The Metering System is a combination of +;;; o the Monitor package written by Chris McConnell +;;; o the Profile package written by Skef Wholey and Rob MacLachlan +;;; The two systems were merged and extended by Mark Kantrowitz. +;;; +;;; Address: Carnegie Mellon University +;;; School of Computer Science +;;; Pittsburgh, PA 15213 +;;; +;;; This code is in the public domain and is distributed without warranty +;;; of any kind. +;;; +;;; This copy is from SLIME, http://www.common-lisp.net/project/slime/ +;;; +;;; + +;;; ******************************** +;;; Change Log ********************* +;;; ******************************** +;;; +;;; 26-JUN-90 mk Merged functionality of Monitor and Profile packages. +;;; 26-JUN-90 mk Now handles both inclusive and exclusive statistics +;;; with respect to nested calls. (Allows it to subtract +;;; total monitoring overhead for each function, not just +;;; the time spent monitoring the function itself.) +;;; 26-JUN-90 mk The table is now saved so that one may manipulate +;;; the data (sorting it, etc.) even after the original +;;; source of the data has been cleared. +;;; 25-SEP-90 mk Added get-cons functions for Lucid 3.0, MACL 1.3.2 +;;; required-arguments functions for Lucid 3.0, +;;; Franz Allegro CL, and MACL 1.3.2. +;;; 25-JAN-91 mk Now uses fdefinition if available. +;;; 25-JAN-91 mk Replaced (and :allegro (not :coral)) with :excl. +;;; Much better solution for the fact that both call +;;; themselves :allegro. +;;; 5-JUL-91 mk Fixed warning to occur only when file is loaded +;;; uncompiled. +;;; 5-JUL-91 mk When many unmonitored functions, print out number +;;; instead of whole list. +;;; 24-MAR-92 mk Updated for CLtL2 compatibility. space measuring +;;; doesn't work in MCL, but fixed so that timing +;;; statistics do. +;;; 26-MAR-92 mk Updated for Lispworks. Replaced :ccl with +;;; (and :ccl (not :lispworks)). +;;; 27-MAR-92 mk Added get-cons for Allegro-V4.0. +;;; 01-JAN-93 mk v2.0 Support for MCL 2.0, CMU CL 16d, Allegro V3.1/4.0/4.1, +;;; Lucid 4.0, ibcl +;;; 25-JAN-94 mk v2.1 Patches for CLISP from Bruno Haible. +;;; 01-APR-05 lgorrie Removed support for all Lisps except CLISP and OpenMCL. +;;; Purely to cut down on stale code (e.g. #+cltl2) in this +;;; version that is bundled with SLIME. +;;; 22-Aug-08 stas Define TIME-TYPE for Clozure CL. +;;; 07-Aug-12 heller Break lines at 80 columns +;;; + +;;; ******************************** +;;; To Do ************************** +;;; ******************************** +;;; +;;; - Need get-cons for Allegro, AKCL. +;;; - Speed up monitoring code. Replace use of hash tables with an embedded +;;; offset in an array so that it will be faster than using gethash. +;;; (i.e., svref/closure reference is usually faster than gethash). +;;; - Beware of (get-internal-run-time) overflowing. Yikes! +;;; - Check robustness with respect to profiled functions. +;;; - Check logic of computing inclusive and exclusive time and consing. +;;; Especially wrt incf/setf comment below. Should be incf, so we +;;; sum recursive calls. +;;; - Add option to record caller statistics -- this would list who +;;; called which functions and how often. +;;; - switches to turn timing/CONSING statistics collection on/off. + + +;;; ******************************** +;;; Notes ************************** +;;; ******************************** +;;; +;;; METERING has been tested (successfully) in the following lisps: +;;; CMU Common Lisp (16d, Python Compiler 1.0 ) :new-compiler +;;; CMU Common Lisp (M2.9 15-Aug-90, Compiler M1.8 15-Aug-90) +;;; Macintosh Allegro Common Lisp (1.3.2) +;;; Macintosh Common Lisp (2.0) +;;; ExCL (Franz Allegro CL 3.1.12 [DEC 3100] 11/19/90) :allegro-v3.1 +;;; ExCL (Franz Allegro CL 4.0.1 [Sun4] 2/8/91) :allegro-v4.0 +;;; ExCL (Franz Allegro CL 4.1 [SPARC R1] 8/28/92 14:06) :allegro-v4.1 +;;; ExCL (Franz ACL 5.0.1 [Linux/X86] 6/29/99 16:11) :allegro-v5.0.1 +;;; Lucid CL (Version 2.1 6-DEC-87) +;;; Lucid Common Lisp (3.0) +;;; Lucid Common Lisp (4.0.1 HP-700 12-Aug-91) +;;; AKCL (1.86, June 30, 1987 or later) +;;; Ibuki Common Lisp (Version 2, release 01.027) +;;; CLISP (January 1994) +;;; +;;; METERING needs to be tested in the following lisps: +;;; Symbolics Common Lisp (8.0) +;;; KCL (June 3, 1987 or later) +;;; TI (Release 4.1 or later) +;;; Golden Common Lisp (3.1 IBM-PC) +;;; VAXLisp (2.0, 3.1) +;;; Procyon Common Lisp + + +;;; **************************************************************** +;;; Documentation ************************************************** +;;; **************************************************************** +;;; +;;; This system runs in any valid Common Lisp. Four small +;;; implementation-dependent changes can be made to improve performance +;;; and prettiness. In the section labelled "Implementation Dependent +;;; Changes" below, you should tailor the functions REQUIRED-ARGUMENTS, +;;; GET-CONS, GET-TIME, and TIME-UNITS-PER-SECOND to your implementation +;;; for the best results. If GET-CONS is not specified for your +;;; implementation, no consing information will be reported. The other +;;; functions will default to working forms, albeit inefficient, in +;;; non-CMU implementations. If you tailor these functions for a particular +;;; version of Common Lisp, we'd appreciate receiving the code. +;;; + +;;; **************************************************************** +;;; Usage Notes **************************************************** +;;; **************************************************************** +;;; +;;; SUGGESTED USAGE: +;;; +;;; Start by monitoring big pieces of the program, then carefully choose +;;; which functions close to, but not in, the inner loop are to be +;;; monitored next. Don't monitor functions that are called by other +;;; monitored functions: you will only confuse yourself. +;;; +;;; If the per-call time reported is less than 1/10th of a second, then +;;; consider the clock resolution and profiling overhead before you believe +;;; the time. It may be that you will need to run your program many times +;;; in order to average out to a higher resolution. +;;; +;;; The easiest way to use this package is to load it and execute either +;;; (swank-monitor:with-monitoring (names*) () +;;; your-forms*) +;;; or +;;; (swank-monitor:monitor-form your-form) +;;; The former allows you to specify which functions will be monitored; the +;;; latter monitors all functions in the current package. Both automatically +;;; produce a table of statistics. Other variants can be constructed from +;;; the monitoring primitives, which are described below, along with a +;;; fuller description of these two macros. +;;; +;;; For best results, compile this file before using. +;;; +;;; +;;; CLOCK RESOLUTION: +;;; +;;; Unless you are very lucky, the length of your machine's clock "tick" is +;;; probably much longer than the time it takes a simple function to run. +;;; For example, on the IBM RT, the clock resolution is 1/50th of a second. +;;; This means that if a function is only called a few times, then only the +;;; first couple of decimal places are really meaningful. +;;; +;;; +;;; MONITORING OVERHEAD: +;;; +;;; The added monitoring code takes time to run every time that the monitored +;;; function is called, which can disrupt the attempt to collect timing +;;; information. In order to avoid serious inflation of the times for functions +;;; that take little time to run, an estimate of the overhead due to monitoring +;;; is subtracted from the times reported for each function. +;;; +;;; Although this correction works fairly well, it is not totally accurate, +;;; resulting in times that become increasingly meaningless for functions +;;; with short runtimes. For example, subtracting the estimated overhead +;;; may result in negative times for some functions. This is only a concern +;;; when the estimated profiling overhead is many times larger than +;;; reported total CPU time. +;;; +;;; If you monitor functions that are called by monitored functions, in +;;; :inclusive mode the monitoring overhead for the inner function is +;;; subtracted from the CPU time for the outer function. [We do this by +;;; counting for each function not only the number of calls to *this* +;;; function, but also the number of monitored calls while it was running.] +;;; In :exclusive mode this is not necessary, since we subtract the +;;; monitoring time of inner functions, overhead & all. +;;; +;;; Otherwise, the estimated monitoring overhead is not represented in the +;;; reported total CPU time. The sum of total CPU time and the estimated +;;; monitoring overhead should be close to the total CPU time for the +;;; entire monitoring run (as determined by TIME). +;;; +;;; A timing overhead factor is computed at load time. This will be incorrect +;;; if the monitoring code is run in a different environment than this file +;;; was loaded in. For example, saving a core image on a high performance +;;; machine and running it on a low performance one will result in the use +;;; of an erroneously small overhead factor. +;;; +;;; +;;; If your times vary widely, possible causes are: +;;; - Garbage collection. Try turning it off, then running your code. +;;; Be warned that monitoring code will probably cons when it does +;;; (get-internal-run-time). +;;; - Swapping. If you have enough memory, execute your form once +;;; before monitoring so that it will be swapped into memory. Otherwise, +;;; get a bigger machine! +;;; - Resolution of internal-time-units-per-second. If this value is +;;; too low, then the timings become wild. You can try executing more +;;; of whatever your test is, but that will only work if some of your +;;; paths do not match the timer resolution. +;;; internal-time-units-per-second is so coarse -- on a Symbolics it is +;;; 977, in MACL it is 60. +;;; +;;; + +;;; **************************************************************** +;;; Interface ****************************************************** +;;; **************************************************************** +;;; +;;; WITH-MONITORING (&rest functions) [Macro] +;;; (&optional (nested :exclusive) +;;; (threshold 0.01) +;;; (key :percent-time)) +;;; &body body +;;; The named functions will be set up for monitoring, the body forms executed, +;;; a table of results printed, and the functions unmonitored. The nested, +;;; threshold, and key arguments are passed to report-monitoring below. +;;; +;;; MONITOR-FORM form [Macro] +;;; &optional (nested :exclusive) +;;; (threshold 0.01) +;;; (key :percent-time) +;;; All functions in the current package are set up for monitoring while +;;; the form is executed, and automatically unmonitored after a table of +;;; results has been printed. The nested, threshold, and key arguments +;;; are passed to report-monitoring below. +;;; +;;; *MONITORED-FUNCTIONS* [Variable] +;;; This holds a list of all functions that are currently being monitored. +;;; +;;; MONITOR &rest names [Macro] +;;; The named functions will be set up for monitoring by augmenting +;;; their function definitions with code that gathers statistical information +;;; about code performance. As with the TRACE macro, the function names are +;;; not evaluated. Calls the function SWANK-MONITOR::MONITORING-ENCAPSULATE on each +;;; function name. If no names are specified, returns a list of all +;;; monitored functions. +;;; +;;; If name is not a symbol, it is evaled to return the appropriate +;;; closure. This allows you to monitor closures stored anywhere like +;;; in a variable, array or structure. Most other monitoring packages +;;; can't handle this. +;;; +;;; MONITOR-ALL &optional (package *package*) [Function] +;;; Monitors all functions in the specified package, which defaults to +;;; the current package. +;;; +;;; UNMONITOR &rest names [Macro] +;;; Removes monitoring code from the named functions. If no names are +;;; specified, all currently monitored functions are unmonitored. +;;; +;;; RESET-MONITORING-INFO name [Function] +;;; Resets the monitoring statistics for the specified function. +;;; +;;; RESET-ALL-MONITORING [Function] +;;; Resets the monitoring statistics for all monitored functions. +;;; +;;; MONITORED name [Function] +;;; Predicate to test whether a function is monitored. +;;; +;;; REPORT-MONITORING &optional names [Function] +;;; (nested :exclusive) +;;; (threshold 0.01) +;;; (key :percent-time) +;;; Creates a table of monitoring information for the specified list +;;; of names, and displays the table using display-monitoring-results. +;;; If names is :all or nil, uses all currently monitored functions. +;;; Takes the following arguments: +;;; - NESTED specifies whether nested calls of monitored functions +;;; are included in the times for monitored functions. +;;; o If :inclusive, the per-function information is for the entire +;;; duration of the monitored function, including any calls to +;;; other monitored functions. If functions A and B are monitored, +;;; and A calls B, then the accumulated time and consing for A will +;;; include the time and consing of B. Note: if a function calls +;;; itself recursively, the time spent in the inner call(s) may +;;; be counted several times. +;;; o If :exclusive, the information excludes time attributed to +;;; calls to other monitored functions. This is the default. +;;; - THRESHOLD specifies that only functions which have been executed +;;; more than threshold percent of the time will be reported. Defaults +;;; to 1%. If a threshold of 0 is specified, all functions are listed, +;;; even those with 0 or negative running times (see note on overhead). +;;; - KEY specifies that the table be sorted by one of the following +;;; sort keys: +;;; :function alphabetically by function name +;;; :percent-time by percent of total execution time +;;; :percent-cons by percent of total consing +;;; :calls by number of times the function was called +;;; :time-per-call by average execution time per function +;;; :cons-per-call by average consing per function +;;; :time same as :percent-time +;;; :cons same as :percent-cons +;;; +;;; REPORT &key (names :all) [Function] +;;; (nested :exclusive) +;;; (threshold 0.01) +;;; (sort-key :percent-time) +;;; (ignore-no-calls nil) +;;; +;;; Same as REPORT-MONITORING but we use a nicer keyword interface. +;;; +;;; DISPLAY-MONITORING-RESULTS &optional (threshold 0.01) [Function] +;;; (key :percent-time) +;;; Prints a table showing for each named function: +;;; - the total CPU time used in that function for all calls +;;; - the total number of bytes consed in that function for all calls +;;; - the total number of calls +;;; - the average amount of CPU time per call +;;; - the average amount of consing per call +;;; - the percent of total execution time spent executing that function +;;; - the percent of total consing spent consing in that function +;;; Summary totals of the CPU time, consing, and calls columns are printed. +;;; An estimate of the monitoring overhead is also printed. May be run +;;; even after unmonitoring all the functions, to play with the data. +;;; +;;; SAMPLE TABLE: +#| + Cons + % % Per Total Total +Function Time Cons Calls Sec/Call Call Time Cons +---------------------------------------------------------------------- +FIND-ROLE: 0.58 0.00 136 0.003521 0 0.478863 0 +GROUP-ROLE: 0.35 0.00 365 0.000802 0 0.292760 0 +GROUP-PROJECTOR: 0.05 0.00 102 0.000408 0 0.041648 0 +FEATURE-P: 0.02 0.00 570 0.000028 0 0.015680 0 +---------------------------------------------------------------------- +TOTAL: 1173 0.828950 0 +Estimated total monitoring overhead: 0.88 seconds +|# + +;;; **************************************************************** +;;; METERING ******************************************************* +;;; **************************************************************** + +;;; ******************************** +;;; Warn people using the wrong Lisp +;;; ******************************** + +#-(or clisp openmcl) +(warn "metering.lisp does not support your Lisp implementation!") + +;;; ******************************** +;;; Packages *********************** +;;; ******************************** + +;;; For CLtL2 compatible lisps + +(defpackage "SWANK-MONITOR" (:use "COMMON-LISP") + (:export "*MONITORED-FUNCTIONS*" + "MONITOR" "MONITOR-ALL" "UNMONITOR" "MONITOR-FORM" + "WITH-MONITORING" + "RESET-MONITORING-INFO" "RESET-ALL-MONITORING" + "MONITORED" + "REPORT-MONITORING" + "DISPLAY-MONITORING-RESULTS" + "MONITORING-ENCAPSULATE" "MONITORING-UNENCAPSULATE" + "REPORT")) +(in-package "SWANK-MONITOR") + +;;; Warn user if they're loading the source instead of compiling it first. +(eval-when (eval) + (warn "This file should be compiled before loading for best results.")) + +;;; ******************************** +;;; Version ************************ +;;; ******************************** + +(defparameter *metering-version* "v2.1 25-JAN-94" + "Current version number/date for Metering.") + + +;;; **************************************************************** +;;; Implementation Dependent Definitions *************************** +;;; **************************************************************** + +;;; ******************************** +;;; Timing Functions *************** +;;; ******************************** +;;; The get-time function is called to find the total number of ticks since +;;; the beginning of time. time-units-per-second allows us to convert units +;;; to seconds. + +#-(or clisp openmcl) +(eval-when (compile eval) + (warn + "You may want to supply implementation-specific get-time functions.")) + +(defconstant time-units-per-second internal-time-units-per-second) + +#+openmcl +(progn + (deftype time-type () 'unsigned-byte) + (deftype consing-type () 'unsigned-byte)) + +(defmacro get-time () + `(the time-type (get-internal-run-time))) + +;;; NOTE: In Macintosh Common Lisp, CCL::GCTIME returns the number of +;;; milliseconds spent during GC. We could subtract this from +;;; the value returned by get-internal-run-time to eliminate +;;; the effect of GC on the timing values, but we prefer to let +;;; the user run without GC on. If the application is so big that +;;; it requires GC to complete, then the GC times are part of the +;;; cost of doing business, and will average out in the long run. +;;; If it seems really important to a user that GC times not be +;;; counted, then uncomment the following three lines and read-time +;;; conditionalize the definition of get-time above with #-:openmcl. +;#+openmcl +;(defmacro get-time () +; `(the time-type (- (get-internal-run-time) (ccl:gctime)))) + +;;; ******************************** +;;; Consing Functions ************** +;;; ******************************** +;;; The get-cons macro is called to find the total number of bytes +;;; consed since the beginning of time. + +#+clisp +(defun get-cons () + (multiple-value-bind (real1 real2 run1 run2 gc1 gc2 space1 space2 gccount) + (sys::%%time) + (declare (ignore real1 real2 run1 run2 gc1 gc2 gccount)) + (dpb space1 (byte 24 24) space2))) + +;;; Macintosh Common Lisp 2.0 +;;; Note that this includes bytes that were allocated during GC. +;;; We could subtract this out by advising GC like we did under +;;; MCL 1.3.2, but I'd rather users ran without GC. If they can't +;;; run without GC, then the bytes consed during GC are a cost of +;;; running their program. Metering the code a few times will +;;; avoid the consing values being too lopsided. If a user really really +;;; wants to subtract out the consing during GC, replace the following +;;; two lines with the commented out code. +#+openmcl +(defmacro get-cons () `(the consing-type (ccl::total-bytes-allocated))) + +#-(or clisp openmcl) +(progn + (eval-when (compile eval) + (warn "No consing will be reported unless a get-cons function is ~ + defined.")) + + (defmacro get-cons () '(the consing-type 0))) + +;; actually, neither `get-cons' nor `get-time' are used as is, +;; but only in the following macro `with-time/cons' +#-:clisp +(defmacro with-time/cons ((delta-time delta-cons) form &body post-process) + (let ((start-cons (gensym "START-CONS-")) + (start-time (gensym "START-TIME-"))) + `(let ((,start-time (get-time)) (,start-cons (get-cons))) + (declare (type time-type ,start-time) + (type consing-type ,start-cons)) + (multiple-value-prog1 ,form + (let ((,delta-time (- (get-time) ,start-time)) + (,delta-cons (- (get-cons) ,start-cons))) + ,@post-process))))) + +#+clisp +(progn + (defmacro delta4 (nv1 nv2 ov1 ov2 by) + `(- (dpb (- ,nv1 ,ov1) (byte ,by ,by) ,nv2) ,ov2)) + + (let ((del (find-symbol "DELTA4" "SYS"))) + (when del (setf (fdefinition 'delta4) (fdefinition del)))) + + (if (< internal-time-units-per-second 1000000) + ;; TIME_1: AMIGA, OS/2, UNIX_TIMES + (defmacro delta4-time (new-time1 new-time2 old-time1 old-time2) + `(delta4 ,new-time1 ,new-time2 ,old-time1 ,old-time2 16)) + ;; TIME_2: other UNIX, WIN32 + (defmacro delta4-time (new-time1 new-time2 old-time1 old-time2) + `(+ (* (- ,new-time1 ,old-time1) internal-time-units-per-second) + (- ,new-time2 ,old-time2)))) + + (defmacro delta4-cons (new-cons1 new-cons2 old-cons1 old-cons2) + `(delta4 ,new-cons1 ,new-cons2 ,old-cons1 ,old-cons2 24)) + + ;; avoid consing: when the application conses a lot, + ;; get-cons may return a bignum, so we really should not use it. + (defmacro with-time/cons ((delta-time delta-cons) form &body post-process) + (let ((beg-cons1 (gensym "BEG-CONS1-")) (end-cons1 (gensym "END-CONS1-")) + (beg-cons2 (gensym "BEG-CONS2-")) (end-cons2 (gensym "END-CONS2-")) + (beg-time1 (gensym "BEG-TIME1-")) (end-time1 (gensym "END-TIME1-")) + (beg-time2 (gensym "BEG-TIME2-")) (end-time2 (gensym "END-TIME2-")) + (re1 (gensym)) (re2 (gensym)) (gc1 (gensym)) (gc2 (gensym))) + `(multiple-value-bind (,re1 ,re2 ,beg-time1 ,beg-time2 + ,gc1 ,gc2 ,beg-cons1 ,beg-cons2) + (sys::%%time) + (declare (ignore ,re1 ,re2 ,gc1 ,gc2)) + (multiple-value-prog1 ,form + (multiple-value-bind (,re1 ,re2 ,end-time1 ,end-time2 + ,gc1 ,gc2 ,end-cons1 ,end-cons2) + (sys::%%time) + (declare (ignore ,re1 ,re2 ,gc1 ,gc2)) + (let ((,delta-time (delta4-time ,end-time1 ,end-time2 + ,beg-time1 ,beg-time2)) + (,delta-cons (delta4-cons ,end-cons1 ,end-cons2 + ,beg-cons1 ,beg-cons2))) + ,@post-process))))))) + +;;; ******************************** +;;; Required Arguments ************* +;;; ******************************** +;;; +;;; Required (Fixed) vs Optional Args +;;; +;;; To avoid unnecessary consing in the "encapsulation" code, we find out the +;;; number of required arguments, and use &rest to capture only non-required +;;; arguments. The function Required-Arguments returns two values: the first +;;; is the number of required arguments, and the second is T iff there are any +;;; non-required arguments (e.g. &optional, &rest, &key). + +;;; Lucid, Allegro, and Macintosh Common Lisp +#+openmcl +(defun required-arguments (name) + (let* ((function (symbol-function name)) + (args (ccl:arglist function)) + (pos (position-if #'(lambda (x) + (and (symbolp x) + (let ((name (symbol-name x))) + (and (>= (length name) 1) + (char= (schar name 0) + #\&))))) + args))) + (if pos + (values pos t) + (values (length args) nil)))) + +#+clisp +(defun required-arguments (name) + (multiple-value-bind (name req-num opt-num rest-p key-p keywords allow-p) + (sys::function-signature name t) + (if name ; no error + (values req-num (or (/= 0 opt-num) rest-p key-p keywords allow-p)) + (values 0 t)))) + +#-(or clisp openmcl) +(progn + (eval-when (compile eval) + (warn + "You may want to add an implementation-specific ~ +Required-Arguments function.")) + (eval-when (load eval) + (defun required-arguments (name) + (declare (ignore name)) + (values 0 t)))) + +#| +;;;Examples +(defun square (x) (* x x)) +(defun square2 (x &optional y) (* x x y)) +(defun test (x y &optional (z 3)) 3) +(defun test2 (x y &optional (z 3) &rest fred) 3) + +(required-arguments 'square) => 1 nil +(required-arguments 'square2) => 1 t +(required-arguments 'test) => 2 t +(required-arguments 'test2) => 2 t +|# + + +;;; **************************************************************** +;;; Main METERING Code ********************************************* +;;; **************************************************************** + +;;; ******************************** +;;; Global Variables *************** +;;; ******************************** +(defvar *MONITOR-TIME-OVERHEAD* nil + "The amount of time an empty monitored function costs.") +(defvar *MONITOR-CONS-OVERHEAD* nil + "The amount of cons an empty monitored function costs.") + +(defvar *TOTAL-TIME* 0 + "Total amount of time monitored so far.") +(defvar *TOTAL-CONS* 0 + "Total amount of consing monitored so far.") +(defvar *TOTAL-CALLS* 0 + "Total number of calls monitored so far.") +(proclaim '(type time-type *total-time*)) +(proclaim '(type consing-type *total-cons*)) +(proclaim '(fixnum *total-calls*)) + +;;; ******************************** +;;; Accessor Functions ************* +;;; ******************************** +;;; Perhaps the SYMBOLP should be FBOUNDP? I.e., what about variables +;;; containing closures. +(defmacro PLACE-FUNCTION (function-place) + "Return the function found at FUNCTION-PLACE. Evals FUNCTION-PLACE +if it isn't a symbol, to allow monitoring of closures located in +variables/arrays/structures." + ;; Note that (fboundp 'fdefinition) returns T even if fdefinition + ;; is a macro, which is what we want. + (if (fboundp 'fdefinition) + `(if (fboundp ,function-place) + (fdefinition ,function-place) + (eval ,function-place)) + `(if (symbolp ,function-place) + (symbol-function ,function-place) + (eval ,function-place)))) + +(defsetf PLACE-FUNCTION (function-place) (function) + "Set the function in FUNCTION-PLACE to FUNCTION." + (if (fboundp 'fdefinition) + ;; If we're conforming to CLtL2, use fdefinition here. + `(if (fboundp ,function-place) + (setf (fdefinition ,function-place) ,function) + (eval '(setf ,function-place ',function))) + `(if (symbolp ,function-place) + (setf (symbol-function ,function-place) ,function) + (eval '(setf ,function-place ',function))))) + +#| +;;; before using fdefinition +(defun PLACE-FUNCTION (function-place) + "Return the function found at FUNCTION-PLACE. Evals FUNCTION-PLACE +if it isn't a symbol, to allow monitoring of closures located in +variables/arrays/structures." + (if (symbolp function-place) + (symbol-function function-place) + (eval function-place))) + +(defsetf PLACE-FUNCTION (function-place) (function) + "Set the function in FUNCTION-PLACE to FUNCTION." + `(if (symbolp ,function-place) + (setf (symbol-function ,function-place) ,function) + (eval '(setf ,function-place ',function)))) +|# + +(defun PLACE-FBOUNDP (function-place) + "Test to see if FUNCTION-PLACE is a function." + ;; probably should be + #|(or (and (symbolp function-place)(fboundp function-place)) + (functionp (place-function function-place)))|# + (if (symbolp function-place) + (fboundp function-place) + (functionp (place-function function-place)))) + +(defun PLACE-MACROP (function-place) + "Test to see if FUNCTION-PLACE is a macro." + (when (symbolp function-place) + (macro-function function-place))) + +;;; ******************************** +;;; Measurement Tables ************* +;;; ******************************** +(defvar *monitored-functions* nil + "List of monitored symbols.") + +;;; We associate a METERING-FUNCTIONS structure with each monitored function +;;; name or other closure. This holds the functions that we call to manipulate +;;; the closure which implements the encapsulation. +;;; +(defstruct metering-functions + (name nil) + (old-definition nil :type function) + (new-definition nil :type function) + (read-metering nil :type function) + (reset-metering nil :type function)) + +;;; In general using hash tables in time-critical programs is a bad idea, +;;; because when one has to grow the table and rehash everything, the +;;; timing becomes grossly inaccurate. In this case it is not an issue +;;; because all inserting of entries in the hash table occurs before the +;;; timing commences. The only circumstance in which this could be a +;;; problem is if the lisp rehashes on the next reference to the table, +;;; instead of when the entry which forces a rehash was inserted. +;;; +;;; Note that a similar kind of problem can occur with GC, which is why +;;; one should turn off GC when monitoring code. +;;; +(defvar *monitor* (make-hash-table :test #'equal) + "Hash table in which METERING-FUNCTIONS structures are stored.") +(defun get-monitor-info (name) + (gethash name *monitor*)) +(defsetf get-monitor-info (name) (info) + `(setf (gethash ,name *monitor*) ,info)) + +(defun MONITORED (function-place) + "Test to see if a FUNCTION-PLACE is monitored." + (and (place-fboundp function-place) ; this line necessary? + (get-monitor-info function-place))) + +(defun reset-monitoring-info (name) + "Reset the monitoring info for the specified function." + (let ((finfo (get-monitor-info name))) + (when finfo + (funcall (metering-functions-reset-metering finfo))))) +(defun reset-all-monitoring () + "Reset monitoring info for all functions." + (setq *total-time* 0 + *total-cons* 0 + *total-calls* 0) + (dolist (symbol *monitored-functions*) + (when (monitored symbol) + (reset-monitoring-info symbol)))) + +(defun monitor-info-values (name &optional (nested :exclusive) warn) + "Returns monitoring information values for the named function, +adjusted for overhead." + (let ((finfo (get-monitor-info name))) + (if finfo + (multiple-value-bind (inclusive-time inclusive-cons + exclusive-time exclusive-cons + calls nested-calls) + (funcall (metering-functions-read-metering finfo)) + (unless (or (null warn) + (eq (place-function name) + (metering-functions-new-definition finfo))) + (warn "Funtion ~S has been redefined, so times may be inaccurate.~@ + MONITOR it again to record calls to the new definition." + name)) + (case nested + (:exclusive (values calls + nested-calls + (- exclusive-time + (* calls *monitor-time-overhead*)) + (- exclusive-cons + (* calls *monitor-cons-overhead*)))) + ;; In :inclusive mode, subtract overhead for all the + ;; called functions as well. Nested-calls includes the + ;; calls of the function as well. [Necessary 'cause of + ;; functions which call themselves recursively.] + (:inclusive (values calls + nested-calls + (- inclusive-time + (* nested-calls ;(+ calls) + *monitor-time-overhead*)) + (- inclusive-cons + (* nested-calls ;(+ calls) + *monitor-cons-overhead*)))))) + (values 0 0 0 0)))) + +;;; ******************************** +;;; Encapsulate ******************** +;;; ******************************** +(eval-when (compile load eval) +;; Returns a lambda expression for a function that, when called with the +;; function name, will set up that function for metering. +;; +;; A function is monitored by replacing its definition with a closure +;; created by the following function. The closure records the monitoring +;; data, and updates the data with each call of the function. +;; +;; Other closures are used to read and reset the data. +(defun make-monitoring-encapsulation (min-args optionals-p) + (let (required-args) + (dotimes (i min-args) (push (gensym) required-args)) + `(lambda (name) + (let ((inclusive-time 0) + (inclusive-cons 0) + (exclusive-time 0) + (exclusive-cons 0) + (calls 0) + (nested-calls 0) + (old-definition (place-function name))) + (declare (type time-type inclusive-time) + (type time-type exclusive-time) + (type consing-type inclusive-cons) + (type consing-type exclusive-cons) + (fixnum calls) + (fixnum nested-calls)) + (pushnew name *monitored-functions*) + + (setf (place-function name) + #'(lambda (,@required-args + ,@(when optionals-p + `(&rest optional-args))) + (let ((prev-total-time *total-time*) + (prev-total-cons *total-cons*) + (prev-total-calls *total-calls*) + ;; (old-time inclusive-time) + ;; (old-cons inclusive-cons) + ;; (old-nested-calls nested-calls) + ) + (declare (type time-type prev-total-time) + (type consing-type prev-total-cons) + (fixnum prev-total-calls)) + (with-time/cons (delta-time delta-cons) + ;; form + ,(if optionals-p + `(apply old-definition + ,@required-args optional-args) + `(funcall old-definition ,@required-args)) + ;; post-processing: + ;; Calls + (incf calls) + (incf *total-calls*) + ;; nested-calls includes this call + (incf nested-calls (the fixnum + (- *total-calls* + prev-total-calls))) + ;; (setf nested-calls (+ old-nested-calls + ;; (- *total-calls* + ;; prev-total-calls))) + ;; Time + ;; Problem with inclusive time is that it + ;; currently doesn't add values from recursive + ;; calls to the same function. Change the + ;; setf to an incf to fix this? + (incf inclusive-time (the time-type delta-time)) + ;; (setf inclusive-time (+ delta-time old-time)) + (incf exclusive-time (the time-type + (+ delta-time + (- prev-total-time + *total-time*)))) + (setf *total-time* (the time-type + (+ delta-time + prev-total-time))) + ;; Consing + (incf inclusive-cons (the consing-type delta-cons)) + ;; (setf inclusive-cons (+ delta-cons old-cons)) + (incf exclusive-cons (the consing-type + (+ delta-cons + (- prev-total-cons + *total-cons*)))) + (setf *total-cons* + (the consing-type + (+ delta-cons prev-total-cons))))))) + (setf (get-monitor-info name) + (make-metering-functions + :name name + :old-definition old-definition + :new-definition (place-function name) + :read-metering #'(lambda () + (values inclusive-time + inclusive-cons + exclusive-time + exclusive-cons + calls + nested-calls)) + :reset-metering #'(lambda () + (setq inclusive-time 0 + inclusive-cons 0 + exclusive-time 0 + exclusive-cons 0 + calls 0 + nested-calls 0) + t))))))) +);; End of EVAL-WHEN + +;;; For efficiency reasons, we precompute the encapsulation functions +;;; for a variety of combinations of argument structures +;;; (min-args . optional-p). These are stored in the following hash table +;;; along with any new ones we encounter. Since we're now precomputing +;;; closure functions for common argument signatures, this eliminates +;;; the former need to call COMPILE for each monitored function. +(eval-when (compile eval) + (defconstant precomputed-encapsulations 8)) + +(defvar *existing-encapsulations* (make-hash-table :test #'equal)) +(defun find-encapsulation (min-args optionals-p) + (or (gethash (cons min-args optionals-p) *existing-encapsulations*) + (setf (gethash (cons min-args optionals-p) *existing-encapsulations*) + (compile nil + (make-monitoring-encapsulation min-args optionals-p))))) + +(macrolet ((frob () + (let ((res ())) + (dotimes (i precomputed-encapsulations) + (push `(setf (gethash '(,i . nil) *existing-encapsulations*) + #',(make-monitoring-encapsulation i nil)) + res) + (push `(setf (gethash '(,i . t) *existing-encapsulations*) + #',(make-monitoring-encapsulation i t)) + res)) + `(progn ,@res)))) + (frob)) + +(defun monitoring-encapsulate (name &optional warn) + "Monitor the function Name. If already monitored, unmonitor first." + ;; Saves the current definition of name and inserts a new function which + ;; returns the result of evaluating body. + (cond ((not (place-fboundp name)) ; not a function + (when warn + (warn "Ignoring undefined function ~S." name))) + ((place-macrop name) ; a macro + (when warn + (warn "Ignoring macro ~S." name))) + (t ; tis a function + (when (get-monitor-info name) ; monitored + (when warn + (warn "~S already monitored, so unmonitoring it first." name)) + (monitoring-unencapsulate name)) + (multiple-value-bind (min-args optionals-p) + (required-arguments name) + (funcall (find-encapsulation min-args optionals-p) name))))) + +(defun monitoring-unencapsulate (name &optional warn) + "Removes monitoring encapsulation code from around Name." + (let ((finfo (get-monitor-info name))) + (when finfo ; monitored + (remprop name 'metering-functions) + (setq *monitored-functions* + (remove name *monitored-functions* :test #'equal)) + (if (eq (place-function name) + (metering-functions-new-definition finfo)) + (setf (place-function name) + (metering-functions-old-definition finfo)) + (when warn + (warn "Preserving current definition of redefined function ~S." + name)))))) + +;;; ******************************** +;;; Main Monitoring Functions ****** +;;; ******************************** +(defmacro MONITOR (&rest names) + "Monitor the named functions. As in TRACE, the names are not evaluated. + If a function is already monitored, then unmonitor and remonitor (useful + to notice function redefinition). If a name is undefined, give a warning + and ignore it. See also unmonitor, report-monitoring, + display-monitoring-results and reset-time." + `(progn + ,@(mapcar #'(lambda (name) `(monitoring-encapsulate ',name)) names) + *monitored-functions*)) + +(defmacro UNMONITOR (&rest names) + "Remove the monitoring on the named functions. + Names defaults to the list of all currently monitored functions." + `(dolist (name ,(if names `',names '*monitored-functions*) (values)) + (monitoring-unencapsulate name))) + +(defun MONITOR-ALL (&optional (package *package*)) + "Monitor all functions in the specified package." + (let ((package (if (packagep package) + package + (find-package package)))) + (do-symbols (symbol package) + (when (eq (symbol-package symbol) package) + (monitoring-encapsulate symbol))))) + +(defmacro MONITOR-FORM (form + &optional (nested :exclusive) (threshold 0.01) + (key :percent-time)) + "Monitor the execution of all functions in the current package +during the execution of FORM. All functions that are executed above +THRESHOLD % will be reported." + `(unwind-protect + (progn + (monitor-all) + (reset-all-monitoring) + (prog1 + (time ,form) + (report-monitoring :all ,nested ,threshold ,key :ignore-no-calls))) + (unmonitor))) + +(defmacro WITH-MONITORING ((&rest functions) + (&optional (nested :exclusive) + (threshold 0.01) + (key :percent-time)) + &body body) + "Monitor the specified functions during the execution of the body." + `(unwind-protect + (progn + (dolist (fun ',functions) + (monitoring-encapsulate fun)) + (reset-all-monitoring) + ,@body + (report-monitoring :all ,nested ,threshold ,key)) + (unmonitor))) + +;;; ******************************** +;;; Overhead Calculations ********** +;;; ******************************** +(defconstant overhead-iterations 5000 + "Number of iterations over which the timing overhead is averaged.") + +;;; Perhaps this should return something to frustrate clever compilers. +(defun STUB-FUNCTION (x) + (declare (ignore x)) + nil) +(proclaim '(notinline stub-function)) + +(defun SET-MONITOR-OVERHEAD () + "Determines the average overhead of monitoring by monitoring the execution +of an empty function many times." + (setq *monitor-time-overhead* 0 + *monitor-cons-overhead* 0) + (stub-function nil) + (monitor stub-function) + (reset-all-monitoring) + (let ((overhead-function (symbol-function 'stub-function))) + (dotimes (x overhead-iterations) + (funcall overhead-function overhead-function))) +; (dotimes (x overhead-iterations) +; (stub-function nil)) + (let ((fiter (float overhead-iterations))) + (multiple-value-bind (calls nested-calls time cons) + (monitor-info-values 'stub-function) + (declare (ignore calls nested-calls)) + (setq *monitor-time-overhead* (/ time fiter) + *monitor-cons-overhead* (/ cons fiter)))) + (unmonitor stub-function)) +(set-monitor-overhead) + +;;; ******************************** +;;; Report Data ******************** +;;; ******************************** +(defvar *monitor-results* nil + "A table of monitoring statistics is stored here.") +(defvar *no-calls* nil + "A list of monitored functions which weren't called.") +(defvar *estimated-total-overhead* 0) +;; (proclaim '(type time-type *estimated-total-overhead*)) + +(defstruct (monitoring-info + (:conc-name m-info-) + (:constructor make-monitoring-info + (name calls time cons + percent-time percent-cons + time-per-call cons-per-call))) + name + calls + time + cons + percent-time + percent-cons + time-per-call + cons-per-call) + +(defun REPORT (&key (names :all) + (nested :exclusive) + (threshold 0.01) + (sort-key :percent-time) + (ignore-no-calls nil)) + "Same as REPORT-MONITORING but with a nicer keyword interface" + (declare (type (member :function :percent-time :time :percent-cons + :cons :calls :time-per-call :cons-per-call) + sort-key) + (type (member :inclusive :exclusive) nested)) + (report-monitoring names nested threshold sort-key ignore-no-calls)) + +(defun REPORT-MONITORING (&optional names + (nested :exclusive) + (threshold 0.01) + (key :percent-time) + ignore-no-calls) + "Report the current monitoring state. +The percentage of the total time spent executing unmonitored code +in each function (:exclusive mode), or total time (:inclusive mode) +will be printed together with the number of calls and +the unmonitored time per call. Functions that have been executed +below THRESHOLD % of the time will not be reported. To report on all +functions set NAMES to be either NIL or :ALL." + (when (or (null names) (eq names :all)) (setq names *monitored-functions*)) + + (let ((total-time 0) + (total-cons 0) + (total-calls 0)) + ;; Compute overall time and consing. + (dolist (name names) + (multiple-value-bind (calls nested-calls time cons) + (monitor-info-values name nested :warn) + (declare (ignore nested-calls)) + (incf total-calls calls) + (incf total-time time) + (incf total-cons cons))) + ;; Total overhead. + (setq *estimated-total-overhead* + (/ (* *monitor-time-overhead* total-calls) + time-units-per-second)) + ;; Assemble data for only the specified names (all monitored functions) + (if (zerop total-time) + (format *trace-output* "Not enough execution time to monitor.") + (progn + (setq *monitor-results* nil *no-calls* nil) + (dolist (name names) + (multiple-value-bind (calls nested-calls time cons) + (monitor-info-values name nested) + (declare (ignore nested-calls)) + (when (minusp time) (setq time 0.0)) + (when (minusp cons) (setq cons 0.0)) + (if (zerop calls) + (push (if (symbolp name) + (symbol-name name) + (format nil "~S" name)) + *no-calls*) + (push (make-monitoring-info + (format nil "~S" name) ; name + calls ; calls + (/ time (float time-units-per-second)) ; time in secs + (round cons) ; consing + (/ time (float total-time)) ; percent-time + (if (zerop total-cons) 0 + (/ cons (float total-cons))) ; percent-cons + (/ (/ time (float calls)) ; time-per-call + time-units-per-second) ; sec/call + (round (/ cons (float calls)))) ; cons-per-call + *monitor-results*)))) + (display-monitoring-results threshold key ignore-no-calls))))) + +(defun display-monitoring-results (&optional (threshold 0.01) + (key :percent-time) + (ignore-no-calls t)) + (let ((max-length 8) ; Function header size + (max-cons-length 8) + (total-time 0.0) + (total-consed 0) + (total-calls 0) + (total-percent-time 0) + (total-percent-cons 0)) + (sort-results key) + (dolist (result *monitor-results*) + (when (or (zerop threshold) + (> (m-info-percent-time result) threshold)) + (setq max-length + (max max-length + (length (m-info-name result)))) + (setq max-cons-length + (max max-cons-length + (m-info-cons-per-call result))))) + (incf max-length 2) + (setf max-cons-length (+ 2 (ceiling (log max-cons-length 10)))) + (format *trace-output* + "~%~%~ + ~VT ~VA~ + ~% ~VT % % ~VA ~ +Total Total~ + ~%Function~VT Time Cons Calls Sec/Call ~VA ~ +Time Cons~ + ~%~V,,,'-A" + max-length + max-cons-length "Cons" + max-length + max-cons-length "Per" + max-length + max-cons-length "Call" + (+ max-length 62 (max 0 (- max-cons-length 5))) "-") + (dolist (result *monitor-results*) + (when (or (zerop threshold) + (> (m-info-percent-time result) threshold)) + (format *trace-output* + "~%~A:~VT~6,2F ~6,2F ~7D ~,6F ~VD ~8,3F ~10D" + (m-info-name result) + max-length + (* 100 (m-info-percent-time result)) + (* 100 (m-info-percent-cons result)) + (m-info-calls result) + (m-info-time-per-call result) + max-cons-length + (m-info-cons-per-call result) + (m-info-time result) + (m-info-cons result)) + (incf total-time (m-info-time result)) + (incf total-consed (m-info-cons result)) + (incf total-calls (m-info-calls result)) + (incf total-percent-time (m-info-percent-time result)) + (incf total-percent-cons (m-info-percent-cons result)))) + (format *trace-output* + "~%~V,,,'-A~ + ~%TOTAL:~VT~6,2F ~6,2F ~7D ~9@T ~VA ~8,3F ~10D~ + ~%Estimated monitoring overhead: ~5,2F seconds~ + ~%Estimated total monitoring overhead: ~5,2F seconds" + (+ max-length 62 (max 0 (- max-cons-length 5))) "-" + max-length + (* 100 total-percent-time) + (* 100 total-percent-cons) + total-calls + max-cons-length " " + total-time total-consed + (/ (* *monitor-time-overhead* total-calls) + time-units-per-second) + *estimated-total-overhead*) + (when (and (not ignore-no-calls) *no-calls*) + (setq *no-calls* (sort *no-calls* #'string<)) + (let ((num-no-calls (length *no-calls*))) + (if (> num-no-calls 20) + (format *trace-output* + "~%~@(~r~) monitored functions were not called. ~ + ~%See the variable swank-monitor::*no-calls* for a list." + num-no-calls) + (format *trace-output* + "~%The following monitored functions were not called:~ + ~%~{~<~%~:; ~A~>~}~%" + *no-calls*)))) + (values))) + +(defun sort-results (&optional (key :percent-time)) + (setq *monitor-results* + (case key + (:function (sort *monitor-results* #'string> + :key #'m-info-name)) + ((:percent-time :time) (sort *monitor-results* #'> + :key #'m-info-time)) + ((:percent-cons :cons) (sort *monitor-results* #'> + :key #'m-info-cons)) + (:calls (sort *monitor-results* #'> + :key #'m-info-calls)) + (:time-per-call (sort *monitor-results* #'> + :key #'m-info-time-per-call)) + (:cons-per-call (sort *monitor-results* #'> + :key #'m-info-cons-per-call))))) + +;;; *END OF FILE* + + diff --git a/vim/bundle/slimv/slime/nregex.lisp b/vim/bundle/slimv/slime/nregex.lisp new file mode 100644 index 0000000..43586ef --- /dev/null +++ b/vim/bundle/slimv/slime/nregex.lisp @@ -0,0 +1,523 @@ +;;; +;;; This code was written by: +;;; +;;; Lawrence E. Freil <lef@freil.com> +;;; National Science Center Foundation +;;; Augusta, Georgia 30909 +;;; +;;; This program was released into the public domain on 2005-08-31. +;;; (See the slime-devel mailing list archive for details.) +;;; +;;; nregex.lisp - My 4/8/92 attempt at a Lisp based regular expression +;;; parser. +;;; +;;; This regular expression parser operates by taking a +;;; regular expression and breaking it down into a list +;;; consisting of lisp expressions and flags. The list +;;; of lisp expressions is then taken in turned into a +;;; lambda expression that can be later applied to a +;;; string argument for parsing. +;;;; +;;;; Modifications made 6 March 2001 By Chris Double (chris@double.co.nz) +;;;; to get working with Corman Lisp 1.42, add package statement and export +;;;; relevant functions. +;;;; + +(in-package :cl-user) + +;; Renamed to slime-nregex avoid name clashes with other versions of +;; this file. -- he + +;;;; CND - 6/3/2001 +(defpackage slime-nregex + (:use #:common-lisp) + (:export + #:regex + #:regex-compile + )) + +;;;; CND - 6/3/2001 +(in-package :slime-nregex) + +;;; +;;; First we create a copy of macros to help debug the beast +(eval-when (:compile-toplevel :load-toplevel :execute) +(defvar *regex-debug* nil) ; Set to nil for no debugging code +) + +(defmacro info (message &rest args) + (if *regex-debug* + `(format *standard-output* ,message ,@args))) + +;;; +;;; Declare the global variables for storing the paren index list. +;;; +(defvar *regex-groups* (make-array 10)) +(defvar *regex-groupings* 0) + +;;; +;;; Declare a simple interface for testing. You probably wouldn't want +;;; to use this interface unless you were just calling this once. +;;; +(defun regex (expression string) + "Usage: (regex <expression> <string) + This function will call regex-compile on the expression and then apply + the string to the returned lambda list." + (let ((findit (cond ((stringp expression) + (regex-compile expression)) + ((listp expression) + expression))) + (result nil)) + (if (not (funcall (if (functionp findit) + findit + (eval `(function ,findit))) string)) + (return-from regex nil)) + (if (= *regex-groupings* 0) + (return-from regex t)) + (dotimes (i *regex-groupings*) + (push (funcall 'subseq + string + (car (aref *regex-groups* i)) + (cadr (aref *regex-groups* i))) + result)) + (reverse result))) + +;;; +;;; Declare some simple macros to make the code more readable. +;;; +(defvar *regex-special-chars* "?*+.()[]\\${}") + +(defmacro add-exp (list) + "Add an item to the end of expression" + `(setf expression (append expression ,list))) + +;;; +;;; Define a function that will take a quoted character and return +;;; what the real character should be plus how much of the source +;;; string was used. If the result is a set of characters, return an +;;; array of bits indicating which characters should be set. If the +;;; expression is one of the sub-group matches return a +;;; list-expression that will provide the match. +;;; +(defun regex-quoted (char-string &optional (invert nil)) + "Usage: (regex-quoted <char-string> &optional invert) + Returns either the quoted character or a simple bit vector of bits set for + the matching values" + (let ((first (char char-string 0)) + (result (char char-string 0)) + (used-length 1)) + (cond ((eql first #\n) + (setf result #\NewLine)) + ((eql first #\c) + (setf result #\Return)) + ((eql first #\t) + (setf result #\Tab)) + ((eql first #\d) + (setf result #*0000000000000000000000000000000000000000000000001111111111000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)) + ((eql first #\D) + (setf result #*1111111111111111111111111111111111111111111111110000000000111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111)) + ((eql first #\w) + (setf result #*0000000000000000000000000000000000000000000000001111111111000000011111111111111111111111111000010111111111111111111111111110000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)) + ((eql first #\W) + (setf result #*1111111111111111111111111111111111111111111111110000000000111111100000000000000000000000000111101000000000000000000000000001111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111)) + ((eql first #\b) + (setf result #*0000000001000000000000000000000011000000000010100000000000100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)) + ((eql first #\B) + (setf result #*1111111110111111111111111111111100111111111101011111111111011111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111)) + ((eql first #\s) + (setf result #*0000000001100000000000000000000010000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)) + ((eql first #\S) + (setf result #*1111111110011111111111111111111101111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111)) + ((and (>= (char-code first) (char-code #\0)) + (<= (char-code first) (char-code #\9))) + (if (and (> (length char-string) 2) + (and (>= (char-code (char char-string 1)) (char-code #\0)) + (<= (char-code (char char-string 1)) (char-code #\9)) + (>= (char-code (char char-string 2)) (char-code #\0)) + (<= (char-code (char char-string 2)) (char-code #\9)))) + ;; + ;; It is a single character specified in octal + ;; + (progn + (setf result (do ((x 0 (1+ x)) + (return 0)) + ((= x 2) return) + (setf return (+ (* return 8) + (- (char-code (char char-string x)) + (char-code #\0)))))) + (setf used-length 3)) + ;; + ;; We have a group number replacement. + ;; + (let ((group (- (char-code first) (char-code #\0)))) + (setf result `((let ((nstring (subseq string (car (aref *regex-groups* ,group)) + (cadr (aref *regex-groups* ,group))))) + (if (< length (+ index (length nstring))) + (return-from compare nil)) + (if (not (string= string nstring + :start1 index + :end1 (+ index (length nstring)))) + (return-from compare nil) + (incf index (length nstring))))))))) + (t + (setf result first))) + (if (and (vectorp result) invert) + (bit-xor result #*1111111110011111111111111111111101111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111 t)) + (values result used-length))) + +;;; +;;; Now for the main regex compiler routine. +;;; +(defun regex-compile (source &key (anchored nil)) + "Usage: (regex-compile <expression> [ :anchored (t/nil) ]) + This function take a regular expression (supplied as source) and + compiles this into a lambda list that a string argument can then + be applied to. It is also possible to compile this lambda list + for better performance or to save it as a named function for later + use" + (info "Now entering regex-compile with \"~A\"~%" source) + ;; + ;; This routine works in two parts. + ;; The first pass take the regular expression and produces a list of + ;; operators and lisp expressions for the entire regular expression. + ;; The second pass takes this list and produces the lambda expression. + (let ((expression '()) ; holder for expressions + (group 1) ; Current group index + (group-stack nil) ; Stack of current group endings + (result nil) ; holder for built expression. + (fast-first nil)) ; holder for quick unanchored scan + ;; + ;; If the expression was an empty string then it alway + ;; matches (so lets leave early) + ;; + (if (= (length source) 0) + (return-from regex-compile + '(lambda (&rest args) + (declare (ignore args)) + t))) + ;; + ;; If the first character is a caret then set the anchored + ;; flags and remove if from the expression string. + ;; + (cond ((eql (char source 0) #\^) + (setf source (subseq source 1)) + (setf anchored t))) + ;; + ;; If the first sequence is .* then also set the anchored flags. + ;; (This is purely for optimization, it will work without this). + ;; + (if (>= (length source) 2) + (if (string= source ".*" :start1 0 :end1 2) + (setf anchored t))) + ;; + ;; Also, If this is not an anchored search and the first character is + ;; a literal, then do a quick scan to see if it is even in the string. + ;; If not then we can issue a quick nil, + ;; otherwise we can start the search at the matching character to skip + ;; the checks of the non-matching characters anyway. + ;; + ;; If I really wanted to speed up this section of code it would be + ;; easy to recognize the case of a fairly long multi-character literal + ;; and generate a Boyer-Moore search for the entire literal. + ;; + ;; I generate the code to do a loop because on CMU Lisp this is about + ;; twice as fast a calling position. + ;; + (if (and (not anchored) + (not (position (char source 0) *regex-special-chars*)) + (not (and (> (length source) 1) + (position (char source 1) *regex-special-chars*)))) + (setf fast-first `((if (not (dotimes (i length nil) + (if (eql (char string i) + ,(char source 0)) + (return (setf start i))))) + (return-from final-return nil))))) + ;; + ;; Generate the very first expression to save the starting index + ;; so that group 0 will be the entire string matched always + ;; + (add-exp '((setf (aref *regex-groups* 0) + (list index nil)))) + ;; + ;; Loop over each character in the regular expression building the + ;; expression list as we go. + ;; + (do ((eindex 0 (1+ eindex))) + ((= eindex (length source))) + (let ((current (char source eindex))) + (info "Now processing character ~A index = ~A~%" current eindex) + (case current + ((#\.) + ;; + ;; Generate code for a single wild character + ;; + (add-exp '((if (>= index length) + (return-from compare nil) + (incf index))))) + ((#\$) + ;; + ;; If this is the last character of the expression then + ;; anchor the end of the expression, otherwise let it slide + ;; as a standard character (even though it should be quoted). + ;; + (if (= eindex (1- (length source))) + (add-exp '((if (not (= index length)) + (return-from compare nil)))) + (add-exp '((if (not (and (< index length) + (eql (char string index) #\$))) + (return-from compare nil) + (incf index)))))) + ((#\*) + (add-exp '(ASTRISK))) + + ((#\+) + (add-exp '(PLUS))) + + ((#\?) + (add-exp '(QUESTION))) + + ((#\() + ;; + ;; Start a grouping. + ;; + (incf group) + (push group group-stack) + (add-exp `((setf (aref *regex-groups* ,(1- group)) + (list index nil)))) + (add-exp `(,group))) + ((#\)) + ;; + ;; End a grouping + ;; + (let ((group (pop group-stack))) + (add-exp `((setf (cadr (aref *regex-groups* ,(1- group))) + index))) + (add-exp `(,(- group))))) + ((#\[) + ;; + ;; Start of a range operation. + ;; Generate a bit-vector that has one bit per possible character + ;; and then on each character or range, set the possible bits. + ;; + ;; If the first character is carat then invert the set. + (let* ((invert (eql (char source (1+ eindex)) #\^)) + (bitstring (make-array 256 :element-type 'bit + :initial-element + (if invert 1 0))) + (set-char (if invert 0 1))) + (if invert (incf eindex)) + (do ((x (1+ eindex) (1+ x))) + ((eql (char source x) #\]) (setf eindex x)) + (info "Building range with character ~A~%" (char source x)) + (cond ((and (eql (char source (1+ x)) #\-) + (not (eql (char source (+ x 2)) #\]))) + (if (>= (char-code (char source x)) + (char-code (char source (+ 2 x)))) + (error "Invalid range \"~A-~A\". Ranges must be in acending order" + (char source x) (char source (+ 2 x)))) + (do ((j (char-code (char source x)) (1+ j))) + ((> j (char-code (char source (+ 2 x)))) + (incf x 2)) + (info "Setting bit for char ~A code ~A~%" (code-char j) j) + (setf (sbit bitstring j) set-char))) + (t + (cond ((not (eql (char source x) #\])) + (let ((char (char source x))) + ;; + ;; If the character is quoted then find out what + ;; it should have been + ;; + (if (eql (char source x) #\\ ) + (let ((length)) + (multiple-value-setq (char length) + (regex-quoted (subseq source x) invert)) + (incf x length))) + (info "Setting bit for char ~A code ~A~%" char (char-code char)) + (if (not (vectorp char)) + (setf (sbit bitstring (char-code (char source x))) set-char) + (bit-ior bitstring char t)))))))) + (add-exp `((let ((range ,bitstring)) + (if (>= index length) + (return-from compare nil)) + (if (= 1 (sbit range (char-code (char string index)))) + (incf index) + (return-from compare nil))))))) + ((#\\ ) + ;; + ;; Intreprete the next character as a special, range, octal, group or + ;; just the character itself. + ;; + (let ((length) + (value)) + (multiple-value-setq (value length) + (regex-quoted (subseq source (1+ eindex)) nil)) + (cond ((listp value) + (add-exp value)) + ((characterp value) + (add-exp `((if (not (and (< index length) + (eql (char string index) + ,value))) + (return-from compare nil) + (incf index))))) + ((vectorp value) + (add-exp `((let ((range ,value)) + (if (>= index length) + (return-from compare nil)) + (if (= 1 (sbit range (char-code (char string index)))) + (incf index) + (return-from compare nil))))))) + (incf eindex length))) + (t + ;; + ;; We have a literal character. + ;; Scan to see how many we have and if it is more than one + ;; generate a string= verses as single eql. + ;; + (let* ((lit "") + (term (dotimes (litindex (- (length source) eindex) nil) + (let ((litchar (char source (+ eindex litindex)))) + (if (position litchar *regex-special-chars*) + (return litchar) + (progn + (info "Now adding ~A index ~A to lit~%" litchar + litindex) + (setf lit (concatenate 'string lit + (string litchar))))))))) + (if (= (length lit) 1) + (add-exp `((if (not (and (< index length) + (eql (char string index) ,current))) + (return-from compare nil) + (incf index)))) + ;; + ;; If we have a multi-character literal then we must + ;; check to see if the next character (if there is one) + ;; is an astrisk or a plus or a question mark. If so then we must not use this + ;; character in the big literal. + (progn + (if (or (eql term #\*) + (eql term #\+) + (eql term #\?)) + (setf lit (subseq lit 0 (1- (length lit))))) + (add-exp `((if (< length (+ index ,(length lit))) + (return-from compare nil)) + (if (not (string= string ,lit :start1 index + :end1 (+ index ,(length lit)))) + (return-from compare nil) + (incf index ,(length lit))))))) + (incf eindex (1- (length lit)))))))) + ;; + ;; Plug end of list to return t. If we made it this far then + ;; We have matched! + (add-exp '((setf (cadr (aref *regex-groups* 0)) + index))) + (add-exp '((return-from final-return t))) + ;; +;;; (print expression) + ;; + ;; Now take the expression list and turn it into a lambda expression + ;; replacing the special flags with lisp code. + ;; For example: A BEGIN needs to be replace by an expression that + ;; saves the current index, then evaluates everything till it gets to + ;; the END then save the new index if it didn't fail. + ;; On an ASTRISK I need to take the previous expression and wrap + ;; it in a do that will evaluate the expression till an error + ;; occurs and then another do that encompases the remainder of the + ;; regular expression and iterates decrementing the index by one + ;; of the matched expression sizes and then returns nil. After + ;; the last expression insert a form that does a return t so that + ;; if the entire nested sub-expression succeeds then the loop + ;; is broken manually. + ;; + (setf result (copy-tree nil)) + ;; + ;; Reversing the current expression makes building up the + ;; lambda list easier due to the nexting of expressions when + ;; and astrisk has been encountered. + (setf expression (reverse expression)) + (do ((elt 0 (1+ elt))) + ((>= elt (length expression))) + (let ((piece (nth elt expression))) + ;; + ;; Now check for PLUS, if so then ditto the expression and then let the + ;; ASTRISK below handle the rest. + ;; + (cond ((eql piece 'PLUS) + (cond ((listp (nth (1+ elt) expression)) + (setf result (append (list (nth (1+ elt) expression)) + result))) + ;; + ;; duplicate the entire group + ;; NOTE: This hasn't been implemented yet!! + (t + (error "GROUP repeat hasn't been implemented yet~%"))))) + (cond ((listp piece) ;Just append the list + (setf result (append (list piece) result))) + ((eql piece 'QUESTION) ; Wrap it in a block that won't fail + (cond ((listp (nth (1+ elt) expression)) + (setf result + (append `((progn (block compare + ,(nth (1+ elt) + expression)) + t)) + result)) + (incf elt)) + ;; + ;; This is a QUESTION on an entire group which + ;; hasn't been implemented yet!!! + ;; + (t + (error "Optional groups not implemented yet~%")))) + ((or (eql piece 'ASTRISK) ; Do the wild thing! + (eql piece 'PLUS)) + (cond ((listp (nth (1+ elt) expression)) + ;; + ;; This is a single character wild card so + ;; do the simple form. + ;; + (setf result + `((let ((oindex index)) + (block compare + (do () + (nil) + ,(nth (1+ elt) expression))) + (do ((start index (1- start))) + ((< start oindex) nil) + (let ((index start)) + (block compare + ,@result)))))) + (incf elt)) + (t + ;; + ;; This is a subgroup repeated so I must build + ;; the loop using several values. + ;; + )) + ) + (t t)))) ; Just ignore everything else. + ;; + ;; Now wrap the result in a lambda list that can then be + ;; invoked or compiled, however the user wishes. + ;; + (if anchored + (setf result + `(lambda (string &key (start 0) (end (length string))) + (setf *regex-groupings* ,group) + (block final-return + (block compare + (let ((index start) + (length end)) + ,@result))))) + (setf result + `(lambda (string &key (start 0) (end (length string))) + (setf *regex-groupings* ,group) + (block final-return + (let ((length end)) + ,@fast-first + (do ((marker start (1+ marker))) + ((> marker end) nil) + (let ((index marker)) + (if (block compare + ,@result) + (return t))))))))))) + +;; (provide 'nregex) diff --git a/vim/bundle/slimv/slime/packages.lisp b/vim/bundle/slimv/slime/packages.lisp new file mode 100644 index 0000000..df7b929 --- /dev/null +++ b/vim/bundle/slimv/slime/packages.lisp @@ -0,0 +1,194 @@ +(defpackage swank/backend + (:use cl) + (:nicknames swank-backend) + (:export *debug-swank-backend* + *log-output* + sldb-condition + compiler-condition + original-condition + message + source-context + condition + severity + with-compilation-hooks + make-location + location + location-p + location-buffer + location-position + location-hints + position-p + position-pos + print-output-to-string + quit-lisp + references + unbound-slot-filler + declaration-arglist + type-specifier-arglist + with-struct + when-let + defimplementation + converting-errors-to-error-location + make-error-location + deinit-log-output + ;; interrupt macro for the backend + *pending-slime-interrupts* + check-slime-interrupts + *interrupt-queued-handler* + ;; inspector related symbols + emacs-inspect + label-value-line + label-value-line* + boolean-to-feature-expression + with-symbol + choose-symbol + ;; package helper for backend + import-to-swank-mop + import-swank-mop-symbols + ;; + default-directory + set-default-directory + frame-source-location + restart-frame + gdb-initial-commands + sldb-break-on-return + buffer-first-change + + profiled-functions + unprofile-all + profile-report + profile-reset + profile-package + + with-collected-macro-forms)) + +(defpackage swank/rpc + (:use :cl) + (:export + read-message + swank-reader-error + swank-reader-error.packet + swank-reader-error.cause + write-message)) + +(defpackage swank/match + (:use cl) + (:export match)) + +;; FIXME: rename to sawnk/mop +(defpackage swank-mop + (:use) + (:export + ;; classes + standard-generic-function + standard-slot-definition + standard-method + standard-class + eql-specializer + eql-specializer-object + ;; standard-class readers + class-default-initargs + class-direct-default-initargs + class-direct-slots + class-direct-subclasses + class-direct-superclasses + class-finalized-p + class-name + class-precedence-list + class-prototype + class-slots + specializer-direct-methods + ;; generic function readers + generic-function-argument-precedence-order + generic-function-declarations + generic-function-lambda-list + generic-function-methods + generic-function-method-class + generic-function-method-combination + generic-function-name + ;; method readers + method-generic-function + method-function + method-lambda-list + method-specializers + method-qualifiers + ;; slot readers + slot-definition-allocation + slot-definition-documentation + slot-definition-initargs + slot-definition-initform + slot-definition-initfunction + slot-definition-name + slot-definition-type + slot-definition-readers + slot-definition-writers + slot-boundp-using-class + slot-value-using-class + slot-makunbound-using-class + ;; generic function protocol + compute-applicable-methods-using-classes + finalize-inheritance)) + +(defpackage swank + (:use cl swank/backend swank/match swank/rpc) + (:export #:startup-multiprocessing + #:start-server + #:create-server + #:stop-server + #:restart-server + #:ed-in-emacs + #:inspect-in-emacs + #:print-indentation-lossage + #:invoke-slime-debugger + #:swank-debugger-hook + #:emacs-inspect + ;;#:inspect-slot-for-emacs + ;; These are user-configurable variables: + #:*communication-style* + #:*dont-close* + #:*fasl-pathname-function* + #:*log-events* + #:*use-dedicated-output-stream* + #:*dedicated-output-stream-port* + #:*configure-emacs-indentation* + #:*readtable-alist* + #:*globally-redirect-io* + #:*global-debugger* + #:*sldb-quit-restart* + #:*backtrace-printer-bindings* + #:*default-worker-thread-bindings* + #:*macroexpand-printer-bindings* + #:*swank-pprint-bindings* + #:*record-repl-results* + #:*inspector-verbose* + ;; This is SETFable. + #:debug-on-swank-error + ;; These are re-exported directly from the backend: + #:buffer-first-change + #:frame-source-location + #:gdb-initial-commands + #:restart-frame + #:sldb-step + #:sldb-break + #:sldb-break-on-return + #:profiled-functions + #:profile-report + #:profile-reset + #:unprofile-all + #:profile-package + #:default-directory + #:set-default-directory + #:quit-lisp + #:eval-for-emacs + #:eval-in-emacs + #:y-or-n-p-in-emacs + #:*find-definitions-right-trim* + #:*find-definitions-left-trim* + #:*after-toggle-trace-hook* + #:unredable-result + #:unredable-result-p + #:unredable-result-string + #:parse-string + #:from-string + #:to-string + #:*swank-debugger-condition*)) diff --git a/vim/bundle/slimv/slime/sbcl-pprint-patch.lisp b/vim/bundle/slimv/slime/sbcl-pprint-patch.lisp new file mode 100644 index 0000000..dfdc0bb --- /dev/null +++ b/vim/bundle/slimv/slime/sbcl-pprint-patch.lisp @@ -0,0 +1,332 @@ +;; Pretty printer patch for SBCL, which adds the "annotations" feature +;; required for sending presentations through pretty-printing streams. +;; +;; The section marked "Changed functions" and the DEFSTRUCT +;; PRETTY-STREAM are based on SBCL's pprint.lisp. +;; +;; Public domain. + +(in-package "SB!PRETTY") + +(defstruct (annotation (:include queued-op)) + (handler (constantly nil) :type function) + (record)) + + +(defstruct (pretty-stream (:include sb!kernel:ansi-stream + (out #'pretty-out) + (sout #'pretty-sout) + (misc #'pretty-misc)) + (:constructor make-pretty-stream (target)) + (:copier nil)) + ;; Where the output is going to finally go. + (target (missing-arg) :type stream) + ;; Line length we should format to. Cached here so we don't have to keep + ;; extracting it from the target stream. + (line-length (or *print-right-margin* + (sb!impl::line-length target) + default-line-length) + :type column) + ;; A simple string holding all the text that has been output but not yet + ;; printed. + (buffer (make-string initial-buffer-size) :type (simple-array character (*))) + ;; The index into BUFFER where more text should be put. + (buffer-fill-pointer 0 :type index) + ;; Whenever we output stuff from the buffer, we shift the remaining noise + ;; over. This makes it difficult to keep references to locations in + ;; the buffer. Therefore, we have to keep track of the total amount of + ;; stuff that has been shifted out of the buffer. + (buffer-offset 0 :type posn) + ;; The column the first character in the buffer will appear in. Normally + ;; zero, but if we end up with a very long line with no breaks in it we + ;; might have to output part of it. Then this will no longer be zero. + (buffer-start-column (or (sb!impl::charpos target) 0) :type column) + ;; The line number we are currently on. Used for *PRINT-LINES* + ;; abbreviations and to tell when sections have been split across + ;; multiple lines. + (line-number 0 :type index) + ;; the value of *PRINT-LINES* captured at object creation time. We + ;; use this, instead of the dynamic *PRINT-LINES*, to avoid + ;; weirdness like + ;; (let ((*print-lines* 50)) + ;; (pprint-logical-block .. + ;; (dotimes (i 10) + ;; (let ((*print-lines* 8)) + ;; (print (aref possiblybigthings i) prettystream))))) + ;; terminating the output of the entire logical blockafter 8 lines. + (print-lines *print-lines* :type (or index null) :read-only t) + ;; Stack of logical blocks in effect at the buffer start. + (blocks (list (make-logical-block)) :type list) + ;; Buffer holding the per-line prefix active at the buffer start. + ;; Indentation is included in this. The length of this is stored + ;; in the logical block stack. + (prefix (make-string initial-buffer-size) :type (simple-array character (*))) + ;; Buffer holding the total remaining suffix active at the buffer start. + ;; The characters are right-justified in the buffer to make it easier + ;; to output the buffer. The length is stored in the logical block + ;; stack. + (suffix (make-string initial-buffer-size) :type (simple-array character (*))) + ;; Queue of pending operations. When empty, HEAD=TAIL=NIL. Otherwise, + ;; TAIL holds the first (oldest) cons and HEAD holds the last (newest) + ;; cons. Adding things to the queue is basically (setf (cdr head) (list + ;; new)) and removing them is basically (pop tail) [except that care must + ;; be taken to handle the empty queue case correctly.] + (queue-tail nil :type list) + (queue-head nil :type list) + ;; Block-start queue entries in effect at the queue head. + (pending-blocks nil :type list) + ;; Queue of annotations to the buffer + (annotations-tail nil :type list) + (annotations-head nil :type list)) + + +(defmacro enqueue (stream type &rest args) + (let ((constructor (intern (concatenate 'string + "MAKE-" + (symbol-name type)) + "SB-PRETTY"))) + (once-only ((stream stream) + (entry `(,constructor :posn + (index-posn + (pretty-stream-buffer-fill-pointer + ,stream) + ,stream) + ,@args)) + (op `(list ,entry)) + (head `(pretty-stream-queue-head ,stream))) + `(progn + (if ,head + (setf (cdr ,head) ,op) + (setf (pretty-stream-queue-tail ,stream) ,op)) + (setf (pretty-stream-queue-head ,stream) ,op) + ,entry)))) + +;;; +;;; New helper functions +;;; + +(defun enqueue-annotation (stream handler record) + (enqueue stream annotation :handler handler + :record record)) + +(defun re-enqueue-annotation (stream annotation) + (let* ((annotation-cons (list annotation)) + (head (pretty-stream-annotations-head stream))) + (if head + (setf (cdr head) annotation-cons) + (setf (pretty-stream-annotations-tail stream) annotation-cons)) + (setf (pretty-stream-annotations-head stream) annotation-cons) + nil)) + +(defun re-enqueue-annotations (stream end) + (loop for tail = (pretty-stream-queue-tail stream) then (cdr tail) + while (and tail (not (eql (car tail) end))) + when (annotation-p (car tail)) + do (re-enqueue-annotation stream (car tail)))) + +(defun dequeue-annotation (stream &key end-posn) + (let ((next-annotation (car (pretty-stream-annotations-tail stream)))) + (when next-annotation + (when (or (not end-posn) + (<= (annotation-posn next-annotation) end-posn)) + (pop (pretty-stream-annotations-tail stream)) + (unless (pretty-stream-annotations-tail stream) + (setf (pretty-stream-annotations-head stream) nil)) + next-annotation)))) + +(defun invoke-annotation (stream annotation truncatep) + (let ((target (pretty-stream-target stream))) + (funcall (annotation-handler annotation) + (annotation-record annotation) + target + truncatep))) + +(defun output-buffer-with-annotations (stream end) + (let ((target (pretty-stream-target stream)) + (buffer (pretty-stream-buffer stream)) + (end-posn (index-posn end stream)) + (start 0)) + (loop + for annotation = (dequeue-annotation stream :end-posn end-posn) + while annotation + do + (let ((annotation-index (posn-index (annotation-posn annotation) + stream))) + (when (> annotation-index start) + (write-string buffer target :start start + :end annotation-index) + (setf start annotation-index)) + (invoke-annotation stream annotation nil))) + (when (> end start) + (write-string buffer target :start start :end end)))) + +(defun flush-annotations (stream end truncatep) + (let ((end-posn (index-posn end stream))) + (loop + for annotation = (dequeue-annotation stream :end-posn end-posn) + while annotation + do (invoke-annotation stream annotation truncatep)))) + +;;; +;;; Changed functions +;;; + +(defun maybe-output (stream force-newlines-p) + (declare (type pretty-stream stream)) + (let ((tail (pretty-stream-queue-tail stream)) + (output-anything nil)) + (loop + (unless tail + (setf (pretty-stream-queue-head stream) nil) + (return)) + (let ((next (pop tail))) + (etypecase next + (newline + (when (ecase (newline-kind next) + ((:literal :mandatory :linear) t) + (:miser (misering-p stream)) + (:fill + (or (misering-p stream) + (> (pretty-stream-line-number stream) + (logical-block-section-start-line + (first (pretty-stream-blocks stream)))) + (ecase (fits-on-line-p stream + (newline-section-end next) + force-newlines-p) + ((t) nil) + ((nil) t) + (:dont-know + (return)))))) + (setf output-anything t) + (output-line stream next))) + (indentation + (unless (misering-p stream) + (set-indentation stream + (+ (ecase (indentation-kind next) + (:block + (logical-block-start-column + (car (pretty-stream-blocks stream)))) + (:current + (posn-column + (indentation-posn next) + stream))) + (indentation-amount next))))) + (block-start + (ecase (fits-on-line-p stream (block-start-section-end next) + force-newlines-p) + ((t) + ;; Just nuke the whole logical block and make it look like one + ;; nice long literal. (But don't nuke annotations.) + (let ((end (block-start-block-end next))) + (expand-tabs stream end) + (re-enqueue-annotations stream end) + (setf tail (cdr (member end tail))))) + ((nil) + (really-start-logical-block + stream + (posn-column (block-start-posn next) stream) + (block-start-prefix next) + (block-start-suffix next))) + (:dont-know + (return)))) + (block-end + (really-end-logical-block stream)) + (tab + (expand-tabs stream next)) + (annotation + (re-enqueue-annotation stream next)))) + (setf (pretty-stream-queue-tail stream) tail)) + output-anything)) + +(defun output-line (stream until) + (declare (type pretty-stream stream) + (type newline until)) + (let* ((target (pretty-stream-target stream)) + (buffer (pretty-stream-buffer stream)) + (kind (newline-kind until)) + (literal-p (eq kind :literal)) + (amount-to-consume (posn-index (newline-posn until) stream)) + (amount-to-print + (if literal-p + amount-to-consume + (let ((last-non-blank + (position #\space buffer :end amount-to-consume + :from-end t :test #'char/=))) + (if last-non-blank + (1+ last-non-blank) + 0))))) + (output-buffer-with-annotations stream amount-to-print) + (flush-annotations stream amount-to-consume nil) + (let ((line-number (pretty-stream-line-number stream))) + (incf line-number) + (when (and (not *print-readably*) + (pretty-stream-print-lines stream) + (>= line-number (pretty-stream-print-lines stream))) + (write-string " .." target) + (flush-annotations stream + (pretty-stream-buffer-fill-pointer stream) + t) + (let ((suffix-length (logical-block-suffix-length + (car (pretty-stream-blocks stream))))) + (unless (zerop suffix-length) + (let* ((suffix (pretty-stream-suffix stream)) + (len (length suffix))) + (write-string suffix target + :start (- len suffix-length) + :end len)))) + (throw 'line-limit-abbreviation-happened t)) + (setf (pretty-stream-line-number stream) line-number) + (write-char #\newline target) + (setf (pretty-stream-buffer-start-column stream) 0) + (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream)) + (block (first (pretty-stream-blocks stream))) + (prefix-len + (if literal-p + (logical-block-per-line-prefix-end block) + (logical-block-prefix-length block))) + (shift (- amount-to-consume prefix-len)) + (new-fill-ptr (- fill-ptr shift)) + (new-buffer buffer) + (buffer-length (length buffer))) + (when (> new-fill-ptr buffer-length) + (setf new-buffer + (make-string (max (* buffer-length 2) + (+ buffer-length + (floor (* (- new-fill-ptr buffer-length) + 5) + 4))))) + (setf (pretty-stream-buffer stream) new-buffer)) + (replace new-buffer buffer + :start1 prefix-len :start2 amount-to-consume :end2 fill-ptr) + (replace new-buffer (pretty-stream-prefix stream) + :end1 prefix-len) + (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr) + (incf (pretty-stream-buffer-offset stream) shift) + (unless literal-p + (setf (logical-block-section-column block) prefix-len) + (setf (logical-block-section-start-line block) line-number)))))) + +(defun output-partial-line (stream) + (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream)) + (tail (pretty-stream-queue-tail stream)) + (count + (if tail + (posn-index (queued-op-posn (car tail)) stream) + fill-ptr)) + (new-fill-ptr (- fill-ptr count)) + (buffer (pretty-stream-buffer stream))) + (when (zerop count) + (error "Output-partial-line called when nothing can be output.")) + (output-buffer-with-annotations stream count) + (incf (pretty-stream-buffer-start-column stream) count) + (replace buffer buffer :end1 new-fill-ptr :start2 count :end2 fill-ptr) + (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr) + (incf (pretty-stream-buffer-offset stream) count))) + +(defun force-pretty-output (stream) + (maybe-output stream nil) + (expand-tabs stream nil) + (re-enqueue-annotations stream nil) + (output-buffer-with-annotations stream + (pretty-stream-buffer-fill-pointer stream))) +
\ No newline at end of file diff --git a/vim/bundle/slimv/slime/slime.el b/vim/bundle/slimv/slime/slime.el new file mode 100644 index 0000000..feca7e8 --- /dev/null +++ b/vim/bundle/slimv/slime/slime.el @@ -0,0 +1,7501 @@ +;;; slime.el --- Superior Lisp Interaction Mode for Emacs -*-lexical-binding:t-*- + +;; URL: https://github.com/slime/slime +;; Package-Requires: ((cl-lib "0.5") (macrostep "0.9")) +;; Keywords: languages, lisp, slime +;; Version: 2.18 + +;;;; License and Commentary + +;; Copyright (C) 2003 Eric Marsden, Luke Gorrie, Helmut Eller +;; Copyright (C) 2004,2005,2006 Luke Gorrie, Helmut Eller +;; Copyright (C) 2007,2008,2009 Helmut Eller, Tobias C. Rittweiler +;; +;; For a detailed list of contributors, see the manual. +;; +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2 of +;; the License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public +;; License along with this program; if not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +;; MA 02111-1307, USA. + +;;; Commentary: + +;; SLIME is the ``Superior Lisp Interaction Mode for Emacs.'' +;; +;; SLIME extends Emacs with support for interactive programming in +;; Common Lisp. The features are centered around slime-mode, an Emacs +;; minor-mode that complements the standard lisp-mode. While lisp-mode +;; supports editing Lisp source files, slime-mode adds support for +;; interacting with a running Common Lisp process for compilation, +;; debugging, documentation lookup, and so on. +;; +;; The slime-mode programming environment follows the example of +;; Emacs's native Emacs Lisp environment. We have also included good +;; ideas from similar systems (such as ILISP) and some new ideas of +;; our own. +;; +;; SLIME is constructed from two parts: a user-interface written in +;; Emacs Lisp, and a supporting server program written in Common +;; Lisp. The two sides are connected together with a socket and +;; communicate using an RPC-like protocol. +;; +;; The Lisp server is primarily written in portable Common Lisp. The +;; required implementation-specific functionality is specified by a +;; well-defined interface and implemented separately for each Lisp +;; implementation. This makes SLIME readily portable. + +;;; Code: + + +;;;; Dependencies and setup +(eval-and-compile + (require 'cl-lib nil t) + ;; For emacs 23, look for bundled version + (require 'cl-lib "lib/cl-lib")) + +(eval-when-compile (require 'cl)) ; defsetf, lexical-let + +(eval-and-compile + (if (< emacs-major-version 23) + (error "Slime requires an Emacs version of 23, or above"))) + +(require 'hyperspec "lib/hyperspec") +(require 'thingatpt) +(require 'comint) +(require 'pp) +(require 'easymenu) +(require 'outline) +(require 'arc-mode) +(require 'etags) +(require 'compile) + +(eval-when-compile + (require 'apropos) + (require 'gud) + (require 'lisp-mnt)) + +(declare-function lm-version "lisp-mnt") + +(defvar slime-path nil + "Directory containing the Slime package. +This is used to load the supporting Common Lisp library, Swank. +The default value is automatically computed from the location of +the Emacs Lisp package.") +(setq slime-path (file-name-directory load-file-name)) + +(defvar slime-version nil + "The version of SLIME that you're using.") +(setq slime-version + (eval-when-compile + (lm-version + (cl-find "slime.el" + (remove nil + (list load-file-name + (when (boundp 'byte-compile-current-file) + byte-compile-current-file))) + :key #'file-name-nondirectory + :test #'string-equal)))) + +(defvar slime-lisp-modes '(lisp-mode)) +(defvar slime-contribs nil + "A list of contrib packages to load with SLIME.") +(define-obsolete-variable-alias 'slime-setup-contribs +'slime-contribs "2.3.2") + +(defun slime-setup (&optional contribs) + "Setup Emacs so that lisp-mode buffers always use SLIME. +CONTRIBS is a list of contrib packages to load. If `nil', use +`slime-contribs'. " + (interactive) + (when (member 'lisp-mode slime-lisp-modes) + (add-hook 'lisp-mode-hook 'slime-lisp-mode-hook)) + (when contribs + (setq slime-contribs contribs)) + (slime--setup-contribs)) + +(defvar slime-required-modules '()) + +(defun slime--setup-contribs () + "Load and initialize contribs." + (dolist (c slime-contribs) + (unless (featurep c) + (require c) + (let ((init (intern (format "%s-init" c)))) + (when (fboundp init) + (funcall init)))))) + +(defun slime-lisp-mode-hook () + (slime-mode 1) + (set (make-local-variable 'lisp-indent-function) + 'common-lisp-indent-function)) + +(defvar slime-protocol-version nil) +(setq slime-protocol-version slime-version) + + +;;;; Customize groups +;; +;;;;; slime + +(defgroup slime nil + "Interaction with the Superior Lisp Environment." + :prefix "slime-" + :group 'applications) + +;;;;; slime-ui + +(defgroup slime-ui nil + "Interaction with the Superior Lisp Environment." + :prefix "slime-" + :group 'slime) + +(defcustom slime-truncate-lines t + "Set `truncate-lines' in popup buffers. +This applies to buffers that present lines as rows of data, such as +debugger backtraces and apropos listings." + :type 'boolean + :group 'slime-ui) + +(defcustom slime-kill-without-query-p nil + "If non-nil, kill SLIME processes without query when quitting Emacs. +This applies to the *inferior-lisp* buffer and the network connections." + :type 'boolean + :group 'slime-ui) + +;;;;; slime-lisp + +(defgroup slime-lisp nil + "Lisp server configuration." + :prefix "slime-" + :group 'slime) + +(defcustom slime-backend "swank-loader.lisp" + "The name of the Lisp file that loads the Swank server. +This name is interpreted relative to the directory containing +slime.el, but could also be set to an absolute filename." + :type 'string + :group 'slime-lisp) + +(defcustom slime-connected-hook nil + "List of functions to call when SLIME connects to Lisp." + :type 'hook + :group 'slime-lisp) + +(defcustom slime-enable-evaluate-in-emacs nil + "*If non-nil, the inferior Lisp can evaluate arbitrary forms in Emacs. +The default is nil, as this feature can be a security risk." + :type '(boolean) + :group 'slime-lisp) + +(defcustom slime-lisp-host "127.0.0.1" + "The default hostname (or IP address) to connect to." + :type 'string + :group 'slime-lisp) + +(defcustom slime-port 4005 + "Port to use as the default for `slime-connect'." + :type 'integer + :group 'slime-lisp) + +(defvar slime-connect-host-history (list slime-lisp-host)) +(defvar slime-connect-port-history (list (prin1-to-string slime-port))) + +(defvar slime-net-valid-coding-systems + '((iso-latin-1-unix nil "iso-latin-1-unix") + (iso-8859-1-unix nil "iso-latin-1-unix") + (binary nil "iso-latin-1-unix") + (utf-8-unix t "utf-8-unix") + (emacs-mule-unix t "emacs-mule-unix") + (euc-jp-unix t "euc-jp-unix")) + "A list of valid coding systems. +Each element is of the form: (NAME MULTIBYTEP CL-NAME)") + +(defun slime-find-coding-system (name) + "Return the coding system for the symbol NAME. +The result is either an element in `slime-net-valid-coding-systems' +of nil." + (let ((probe (assq name slime-net-valid-coding-systems))) + (when (and probe (if (fboundp 'check-coding-system) + (ignore-errors (check-coding-system (car probe))) + (eq (car probe) 'binary))) + probe))) + +(defcustom slime-net-coding-system + (car (cl-find-if 'slime-find-coding-system + slime-net-valid-coding-systems :key 'car)) + "Coding system used for network connections. +See also `slime-net-valid-coding-systems'." + :type (cons 'choice + (mapcar (lambda (x) + (list 'const (car x))) + slime-net-valid-coding-systems)) + :group 'slime-lisp) + +;;;;; slime-mode + +(defgroup slime-mode nil + "Settings for slime-mode Lisp source buffers." + :prefix "slime-" + :group 'slime) + +(defcustom slime-find-definitions-function 'slime-find-definitions-rpc + "Function to find definitions for a name. +The function is called with the definition name, a string, as its +argument." + :type 'function + :group 'slime-mode + :options '(slime-find-definitions-rpc + slime-etags-definitions + (lambda (name) + (append (slime-find-definitions-rpc name) + (slime-etags-definitions name))) + (lambda (name) + (or (slime-find-definitions-rpc name) + (and tags-table-list + (slime-etags-definitions name)))))) + +;; FIXME: remove one day +(defcustom slime-complete-symbol-function 'nil + "Obsolete. Use `slime-completion-at-point-functions' instead." + :group 'slime-mode + :type '(choice (const :tag "Compound" slime-complete-symbol*) + (const :tag "Fuzzy" slime-fuzzy-complete-symbol))) + +(make-obsolete-variable 'slime-complete-symbol-function + 'slime-completion-at-point-functions + "2015-10-18") + +(defcustom slime-completion-at-point-functions + '(slime-filename-completion + slime-simple-completion-at-point) + "List of functions to perform completion. +Works like `completion-at-point-functions'. +`slime--completion-at-point' uses this variable." + :group 'slime-mode) + +;;;;; slime-mode-faces + +(defgroup slime-mode-faces nil + "Faces in slime-mode source code buffers." + :prefix "slime-" + :group 'slime-mode) + +(defface slime-error-face + `((((class color) (background light)) + (:underline "red")) + (((class color) (background dark)) + (:underline "red")) + (t (:underline t))) + "Face for errors from the compiler." + :group 'slime-mode-faces) + +(defface slime-warning-face + `((((class color) (background light)) + (:underline "orange")) + (((class color) (background dark)) + (:underline "coral")) + (t (:underline t))) + "Face for warnings from the compiler." + :group 'slime-mode-faces) + +(defface slime-style-warning-face + `((((class color) (background light)) + (:underline "brown")) + (((class color) (background dark)) + (:underline "gold")) + (t (:underline t))) + "Face for style-warnings from the compiler." + :group 'slime-mode-faces) + +(defface slime-note-face + `((((class color) (background light)) + (:underline "brown4")) + (((class color) (background dark)) + (:underline "light goldenrod")) + (t (:underline t))) + "Face for notes from the compiler." + :group 'slime-mode-faces) + +(defface slime-highlight-face + '((t (:inherit highlight :underline nil))) + "Face for compiler notes while selected." + :group 'slime-mode-faces) + +;;;;; sldb + +(defgroup slime-debugger nil + "Backtrace options and fontification." + :prefix "sldb-" + :group 'slime) + +(defmacro define-sldb-faces (&rest faces) + "Define the set of SLDB faces. +Each face specifiation is (NAME DESCRIPTION &optional PROPERTIES). +NAME is a symbol; the face will be called sldb-NAME-face. +DESCRIPTION is a one-liner for the customization buffer. +PROPERTIES specifies any default face properties." + `(progn ,@(cl-loop for face in faces + collect `(define-sldb-face ,@face)))) + +(defmacro define-sldb-face (name description &optional default) + (let ((facename (intern (format "sldb-%s-face" (symbol-name name))))) + `(defface ,facename + (list (list t ,default)) + ,(format "Face for %s." description) + :group 'slime-debugger))) + +(define-sldb-faces + (topline "the top line describing the error") + (condition "the condition class" + '(:inherit font-lock-warning-face)) + (section "the labels of major sections in the debugger buffer" + '(:inherit header-line)) + (frame-label "backtrace frame numbers" + '(:inherit shadow)) + (restart-type "restart names." + '(:inherit font-lock-keyword-face)) + (restart "restart descriptions") + (restart-number "restart numbers (correspond to keystrokes to invoke)" + '(:bold t)) + (frame-line "function names and arguments in the backtrace") + (restartable-frame-line + "frames which are surely restartable" + '(:foreground "lime green")) + (non-restartable-frame-line + "frames which are surely not restartable") + (detailed-frame-line + "function names and arguments in a detailed (expanded) frame") + (local-name "local variable names" + '(:inherit font-lock-variable-name-face)) + (local-value "local variable values") + (catch-tag "catch tags" + '(:inherit highlight))) + + +;;;; Minor modes + +;;;;; slime-mode + +(defvar slime-mode-indirect-map (make-sparse-keymap) + "Empty keymap which has `slime-mode-map' as it's parent. +This is a hack so that we can reinitilize the real slime-mode-map +more easily. See `slime-init-keymaps'.") + +(defvar slime-buffer-connection) +(defvar slime-dispatching-connection) +(defvar slime-current-thread) + +(defun slime--on () + (slime-setup-completion)) + +(defun slime--off () + (remove-hook 'completion-at-point-functions #'slime--completion-at-point t)) + +(define-minor-mode slime-mode + "\\<slime-mode-map>\ +SLIME: The Superior Lisp Interaction Mode for Emacs (minor-mode). + +Commands to compile the current buffer's source file and visually +highlight any resulting compiler notes and warnings: +\\[slime-compile-and-load-file] - Compile and load the current buffer's file. +\\[slime-compile-file] - Compile (but not load) the current buffer's file. +\\[slime-compile-defun] - Compile the top-level form at point. + +Commands for visiting compiler notes: +\\[slime-next-note] - Goto the next form with a compiler note. +\\[slime-previous-note] - Goto the previous form with a compiler note. +\\[slime-remove-notes] - Remove compiler-note annotations in buffer. + +Finding definitions: +\\[slime-edit-definition] +- Edit the definition of the function called at point. +\\[slime-pop-find-definition-stack] +- Pop the definition stack to go back from a definition. + +Documentation commands: +\\[slime-describe-symbol] - Describe symbol. +\\[slime-apropos] - Apropos search. +\\[slime-disassemble-symbol] - Disassemble a function. + +Evaluation commands: +\\[slime-eval-defun] - Evaluate top-level from containing point. +\\[slime-eval-last-expression] - Evaluate sexp before point. +\\[slime-pprint-eval-last-expression] \ +- Evaluate sexp before point, pretty-print result. + +Full set of commands: +\\{slime-mode-map}" + :keymap slime-mode-indirect-map + :lighter (:eval (slime-modeline-string)) + (cond (slime-mode (slime--on)) + (t (slime--off)))) + + +;;;;;; Modeline + +(defun slime-modeline-string () + "Return the string to display in the modeline. +\"Slime\" only appears if we aren't connected. If connected, +include package-name, connection-name, and possibly some state +information." + (let ((conn (slime-current-connection))) + ;; Bail out early in case there's no connection, so we won't + ;; implicitly invoke `slime-connection' which may query the user. + (if (not conn) + (and slime-mode " Slime") + (let ((local (eq conn slime-buffer-connection)) + (pkg (slime-current-package))) + (concat " " + (if local "{" "[") + (if pkg (slime-pretty-package-name pkg) "?") + " " + ;; ignore errors for closed connections + (ignore-errors (slime-connection-name conn)) + (slime-modeline-state-string conn) + (if local "}" "]")))))) + +(defun slime-pretty-package-name (name) + "Return a pretty version of a package name NAME." + (cond ((string-match "^#?:\\(.*\\)$" name) + (match-string 1 name)) + ((string-match "^\"\\(.*\\)\"$" name) + (match-string 1 name)) + (t name))) + +(defun slime-modeline-state-string (conn) + "Return a string possibly describing CONN's state." + (cond ((not (eq (process-status conn) 'open)) + (format " %s" (process-status conn))) + ((let ((pending (length (slime-rex-continuations conn))) + (sldbs (length (sldb-buffers conn)))) + (cond ((and (zerop sldbs) (zerop pending)) nil) + ((zerop sldbs) (format " %s" pending)) + (t (format " %s/%s" pending sldbs))))))) + +(defun slime--recompute-modelines () + (force-mode-line-update t)) + + +;;;;; Key bindings + +(defvar slime-parent-map nil + "Parent keymap for shared between all Slime related modes.") + +(defvar slime-parent-bindings + '(("\M-." slime-edit-definition) + ("\M-," slime-pop-find-definition-stack) + ("\M-_" slime-edit-uses) ; for German layout + ("\M-?" slime-edit-uses) ; for USian layout + ("\C-x4." slime-edit-definition-other-window) + ("\C-x5." slime-edit-definition-other-frame) + ("\C-x\C-e" slime-eval-last-expression) + ("\C-\M-x" slime-eval-defun) + ;; Include PREFIX keys... + ("\C-c" slime-prefix-map))) + +(defvar slime-prefix-map nil + "Keymap for commands prefixed with `slime-prefix-key'.") + +(defvar slime-prefix-bindings + '(("\C-r" slime-eval-region) + (":" slime-interactive-eval) + ("\C-e" slime-interactive-eval) + ("E" slime-edit-value) + ("\C-l" slime-load-file) + ("\C-b" slime-interrupt) + ("\M-d" slime-disassemble-symbol) + ("\C-t" slime-toggle-trace-fdefinition) + ("I" slime-inspect) + ("\C-xt" slime-list-threads) + ("\C-xn" slime-next-connection) + ("\C-xp" slime-prev-connection) + ("\C-xc" slime-list-connections) + ("<" slime-list-callers) + (">" slime-list-callees) + ;; Include DOC keys... + ("\C-d" slime-doc-map) + ;; Include XREF WHO-FOO keys... + ("\C-w" slime-who-map) + )) + +(defvar slime-editing-map nil + "These keys are useful for buffers where the user can insert and +edit s-exprs, e.g. for source buffers and the REPL.") + +(defvar slime-editing-keys + `(;; Arglist display & completion + (" " slime-space) + ;; Evaluating + ;;("\C-x\M-e" slime-eval-last-expression-display-output :inferior t) + ("\C-c\C-p" slime-pprint-eval-last-expression) + ;; Macroexpand + ("\C-c\C-m" slime-expand-1) + ("\C-c\M-m" slime-macroexpand-all) + ;; Misc + ("\C-c\C-u" slime-undefine-function) + (,(kbd "C-M-.") slime-next-location) + (,(kbd "C-M-,") slime-previous-location) + ;; Obsolete, redundant bindings + ("\C-c\C-i" completion-at-point) + ;;("\M-*" pop-tag-mark) ; almost to clever + )) + +(defvar slime-mode-map nil + "Keymap for slime-mode.") + +(defvar slime-keys + '( ;; Compiler notes + ("\M-p" slime-previous-note) + ("\M-n" slime-next-note) + ("\C-c\M-c" slime-remove-notes) + ("\C-c\C-k" slime-compile-and-load-file) + ("\C-c\M-k" slime-compile-file) + ("\C-c\C-c" slime-compile-defun))) + +(defun slime-nop () + "The null command. Used to shadow currently-unused keybindings." + (interactive) + (call-interactively 'undefined)) + +(defvar slime-doc-map nil + "Keymap for documentation commands. Bound to a prefix key.") + +(defvar slime-doc-bindings + '((?a slime-apropos) + (?z slime-apropos-all) + (?p slime-apropos-package) + (?d slime-describe-symbol) + (?f slime-describe-function) + (?h slime-documentation-lookup) + (?~ common-lisp-hyperspec-format) + (?g common-lisp-hyperspec-glossary-term) + (?# common-lisp-hyperspec-lookup-reader-macro))) + +(defvar slime-who-map nil + "Keymap for who-xref commands. Bound to a prefix key.") + +(defvar slime-who-bindings + '((?c slime-who-calls) + (?w slime-calls-who) + (?r slime-who-references) + (?b slime-who-binds) + (?s slime-who-sets) + (?m slime-who-macroexpands) + (?a slime-who-specializes))) + +(defun slime-init-keymaps () + "(Re)initialize the keymaps for `slime-mode'." + (interactive) + (slime-init-keymap 'slime-doc-map t t slime-doc-bindings) + (slime-init-keymap 'slime-who-map t t slime-who-bindings) + (slime-init-keymap 'slime-prefix-map t nil slime-prefix-bindings) + (slime-init-keymap 'slime-parent-map nil nil slime-parent-bindings) + (slime-init-keymap 'slime-editing-map nil nil slime-editing-keys) + (set-keymap-parent slime-editing-map slime-parent-map) + (slime-init-keymap 'slime-mode-map nil nil slime-keys) + (set-keymap-parent slime-mode-map slime-editing-map) + (set-keymap-parent slime-mode-indirect-map slime-mode-map)) + +(defun slime-init-keymap (keymap-name prefixp bothp bindings) + (set keymap-name (make-sparse-keymap)) + (when prefixp (define-prefix-command keymap-name)) + (slime-bind-keys (eval keymap-name) bothp bindings)) + +(defun slime-bind-keys (keymap bothp bindings) + "Add BINDINGS to KEYMAP. +If BOTHP is true also add bindings with control modifier." + (cl-loop for (key command) in bindings do + (cond (bothp + (define-key keymap `[,key] command) + (unless (equal key ?h) ; But don't bind C-h + (define-key keymap `[(control ,key)] command))) + (t (define-key keymap key command))))) + +(slime-init-keymaps) + +(define-minor-mode slime-editing-mode + "Minor mode which makes slime-editing-map available. +\\{slime-editing-map}" + nil + nil + slime-editing-map) + + +;;;; Framework'ey bits +;;; +;;; This section contains some standard SLIME idioms: basic macros, +;;; ways of showing messages to the user, etc. All the code in this +;;; file should use these functions when applicable. +;;; +;;;;; Syntactic sugar + +(defmacro slime-dcase (value &rest patterns) + (declare (indent 1)) + "Dispatch VALUE to one of PATTERNS. +A cross between `case' and `destructuring-bind'. +The pattern syntax is: + ((HEAD . ARGS) . BODY) +The list of patterns is searched for a HEAD `eq' to the car of +VALUE. If one is found, the BODY is executed with ARGS bound to the +corresponding values in the CDR of VALUE." + (let ((operator (cl-gensym "op-")) + (operands (cl-gensym "rand-")) + (tmp (cl-gensym "tmp-"))) + `(let* ((,tmp ,value) + (,operator (car ,tmp)) + (,operands (cdr ,tmp))) + (cl-case ,operator + ,@(mapcar (lambda (clause) + (if (eq (car clause) t) + `(t ,@(cdr clause)) + (cl-destructuring-bind ((op &rest rands) &rest body) + clause + `(,op (cl-destructuring-bind ,rands ,operands + . ,(or body + '((ignore)) ; suppress some warnings + )))))) + patterns) + ,@(if (eq (caar (last patterns)) t) + '() + `((t (error "slime-dcase failed: %S" ,tmp)))))))) + +(defmacro slime-define-keys (keymap &rest key-command) + "Define keys in KEYMAP. Each KEY-COMMAND is a list of (KEY COMMAND)." + (declare (indent 1)) + `(progn . ,(mapcar (lambda (k-c) `(define-key ,keymap . ,k-c)) + key-command))) + +(cl-defmacro with-struct ((conc-name &rest slots) struct &body body) + "Like with-slots but works only for structs. +\(fn (CONC-NAME &rest SLOTS) STRUCT &body BODY)" + (declare (indent 2)) + (let ((struct-var (cl-gensym "struct")) + (reader (lambda (slot) + (intern (concat (symbol-name conc-name) + (symbol-name slot)))))) + `(let ((,struct-var ,struct)) + (cl-symbol-macrolet + ,(mapcar (lambda (slot) + (cl-etypecase slot + (symbol `(,slot (,(funcall reader slot) ,struct-var))) + (cons `(,(cl-first slot) + (,(funcall reader (cl-second slot)) + ,struct-var))))) + slots) + . ,body)))) + +;;;;; Very-commonly-used functions + +(defvar slime-message-function 'message) + +;; Interface +(defun slime-buffer-name (type &optional hidden) + (cl-assert (keywordp type)) + (concat (if hidden " " "") + (format "*slime-%s*" (substring (symbol-name type) 1)))) + +;; Interface +(defun slime-message (format &rest args) + "Like `message' but with special support for multi-line messages. +Single-line messages use the echo area." + (apply slime-message-function format args)) + +(defun slime-display-warning (message &rest args) + (display-warning '(slime warning) (apply #'format message args))) + +(defvar slime-background-message-function 'slime-display-oneliner) + +;; Interface +(defun slime-background-message (format-string &rest format-args) + "Display a message in passing. +This is like `slime-message', but less distracting because it +will never pop up a buffer or display multi-line messages. +It should be used for \"background\" messages such as argument lists." + (apply slime-background-message-function format-string format-args)) + +(defun slime-display-oneliner (format-string &rest format-args) + (let* ((msg (apply #'format format-string format-args))) + (unless (minibuffer-window-active-p (minibuffer-window)) + (message "%s" (slime-oneliner msg))))) + +(defun slime-oneliner (string) + "Return STRING truncated to fit in a single echo-area line." + (substring string 0 (min (length string) + (or (cl-position ?\n string) most-positive-fixnum) + (1- (window-width (minibuffer-window)))))) + +;; Interface +(defun slime-set-truncate-lines () + "Apply `slime-truncate-lines' to the current buffer." + (when slime-truncate-lines + (set (make-local-variable 'truncate-lines) t))) + +;; Interface +(defun slime-read-package-name (prompt &optional initial-value) + "Read a package name from the minibuffer, prompting with PROMPT." + (let ((completion-ignore-case t)) + (completing-read prompt (slime-bogus-completion-alist + (slime-eval + `(swank:list-all-package-names t))) + nil t initial-value))) + +;; Interface +(defun slime-read-symbol-name (prompt &optional query) + "Either read a symbol name or choose the one at point. +The user is prompted if a prefix argument is in effect, if there is no +symbol at point, or if QUERY is non-nil." + (cond ((or current-prefix-arg query (not (slime-symbol-at-point))) + (slime-read-from-minibuffer prompt (slime-symbol-at-point))) + (t (slime-symbol-at-point)))) + +;; Interface +(defmacro slime-propertize-region (props &rest body) + "Execute BODY and add PROPS to all the text it inserts. +More precisely, PROPS are added to the region between the point's +positions before and after executing BODY." + (declare (indent 1) (debug (sexp &rest form))) + (let ((start (cl-gensym))) + `(let ((,start (point))) + (prog1 (progn ,@body) + (add-text-properties ,start (point) ,props))))) + +(defun slime-add-face (face string) + (declare (indent 1)) + (add-text-properties 0 (length string) (list 'face face) string) + string) + +;; Interface +(defsubst slime-insert-propertized (props &rest args) + "Insert all ARGS and then add text-PROPS to the inserted text." + (slime-propertize-region props (apply #'insert args))) + +(defmacro slime-with-rigid-indentation (level &rest body) + "Execute BODY and then rigidly indent its text insertions. +Assumes all insertions are made at point." + (declare (indent 1)) + (let ((start (cl-gensym)) (l (cl-gensym))) + `(let ((,start (point)) (,l ,(or level '(current-column)))) + (prog1 (progn ,@body) + (slime-indent-rigidly ,start (point) ,l))))) + +(defun slime-indent-rigidly (start end column) + ;; Similar to `indent-rigidly' but doesn't inherit text props. + (let ((indent (make-string column ?\ ))) + (save-excursion + (goto-char end) + (beginning-of-line) + (while (and (<= start (point)) + (progn + (insert-before-markers indent) + (zerop (forward-line -1)))))))) + +(defun slime-insert-indented (&rest strings) + "Insert all arguments rigidly indented." + (slime-with-rigid-indentation nil + (apply #'insert strings))) + +(defun slime-property-bounds (prop) + "Return two the positions of the previous and next changes to PROP. +PROP is the name of a text property." + (cl-assert (get-text-property (point) prop)) + (let ((end (next-single-char-property-change (point) prop))) + (list (previous-single-char-property-change end prop) end))) + +(defun slime-curry (fun &rest args) + "Partially apply FUN to ARGS. The result is a new function. +This idiom is preferred over `lexical-let'." + `(lambda (&rest more) (apply ',fun (append ',args more)))) + +(defun slime-rcurry (fun &rest args) + "Like `slime-curry' but ARGS on the right are applied." + `(lambda (&rest more) (apply ',fun (append more ',args)))) + + +;;;;; Temporary popup buffers + +;; keep compiler quiet +(defvar slime-buffer-package) +(defvar slime-buffer-connection) + +;; Interface +(cl-defmacro slime-with-popup-buffer ((name &key package connection select + mode) + &body body) + "Similar to `with-output-to-temp-buffer'. +Bind standard-output and initialize some buffer-local variables. +Restore window configuration when closed. + +NAME is the name of the buffer to be created. +PACKAGE is the value `slime-buffer-package'. +CONNECTION is the value for `slime-buffer-connection', + if nil, no explicit connection is associated with + the buffer. If t, the current connection is taken. +MODE is the name of a major mode which will be enabled. +" + (declare (indent 1)) + (let ((package-sym (cl-gensym "package-")) + (connection-sym (cl-gensym "connection-"))) + `(let ((,package-sym ,(if (eq package t) + `(slime-current-package) + package)) + (,connection-sym ,(if (eq connection t) + `(slime-current-connection) + connection))) + (with-current-buffer (get-buffer-create ,name) + (let ((inhibit-read-only t) + (standard-output (current-buffer))) + (erase-buffer) + (funcall (or ,mode 'fundamental-mode)) + (setq slime-buffer-package ,package-sym + slime-buffer-connection ,connection-sym) + (set-syntax-table lisp-mode-syntax-table) + ,@body + (slime-popup-buffer-mode 1) + (funcall (if ,select 'pop-to-buffer 'display-buffer) + (current-buffer)) + (current-buffer)))))) + +(defvar slime-popup-buffer-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "q") 'quit-window) + ;;("\C-c\C-z" . slime-switch-to-output-buffer) + (define-key map (kbd "M-.") 'slime-edit-definition) + map)) + +(define-minor-mode slime-popup-buffer-mode + "Mode for displaying read only stuff" + nil nil nil + (setq buffer-read-only t)) + +(add-to-list 'minor-mode-alist + `(slime-popup-buffer-mode + (:eval (unless slime-mode + (slime-modeline-string))))) + +(set-keymap-parent slime-popup-buffer-mode-map slime-parent-map) + +;;;;; Filename translation +;;; +;;; Filenames passed between Emacs and Lisp should be translated using +;;; these functions. This way users who run Emacs and Lisp on separate +;;; machines have a chance to integrate file operations somehow. + +(defvar slime-to-lisp-filename-function #'convert-standard-filename + "Function to translate Emacs filenames to CL namestrings.") +(defvar slime-from-lisp-filename-function #'identity + "Function to translate CL namestrings to Emacs filenames.") + +(defun slime-to-lisp-filename (filename) + "Translate the string FILENAME to a Lisp filename." + (funcall slime-to-lisp-filename-function filename)) + +(defun slime-from-lisp-filename (filename) + "Translate the Lisp filename FILENAME to an Emacs filename." + (funcall slime-from-lisp-filename-function filename)) + + +;;;; Starting SLIME +;;; +;;; This section covers starting an inferior-lisp, compiling and +;;; starting the server, initiating a network connection. + +;;;;; Entry points + +;; We no longer load inf-lisp, but we use this variable for backward +;; compatibility. +(defvar inferior-lisp-program "lisp" + "*Program name for invoking an inferior Lisp with for Inferior Lisp mode.") + +(defvar slime-lisp-implementations nil + "*A list of known Lisp implementations. +The list should have the form: + ((NAME (PROGRAM PROGRAM-ARGS...) &key KEYWORD-ARGS) ...) + +NAME is a symbol for the implementation. +PROGRAM and PROGRAM-ARGS are strings used to start the Lisp process. +For KEYWORD-ARGS see `slime-start'. + +Here's an example: + ((cmucl (\"/opt/cmucl/bin/lisp\" \"-quiet\") :init slime-init-command) + (acl (\"acl7\") :coding-system emacs-mule))") + +(defvar slime-default-lisp nil + "*The name of the default Lisp implementation. +See `slime-lisp-implementations'") + +;; dummy definitions for the compiler +(defvar slime-net-processes) +(defvar slime-default-connection) + +(defun slime (&optional command coding-system) + "Start an inferior^_superior Lisp and connect to its Swank server." + (interactive) + (slime-setup) + (let ((inferior-lisp-program (or command inferior-lisp-program)) + (slime-net-coding-system (or coding-system slime-net-coding-system))) + (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'.") + +(defun slime-read-interactive-args () + "Return the list of args which should be passed to `slime-start'. + +The rules for selecting the arguments are rather complicated: + +- In the most common case, i.e. if there's no prefix-arg in + effect and if `slime-lisp-implementations' is nil, use + `inferior-lisp-program' as fallback. + +- If the table `slime-lisp-implementations' is non-nil use the + implementation with name `slime-default-lisp' or if that's nil + the first entry in the table. + +- If the prefix-arg is `-', prompt for one of the registered + lisps. + +- If the prefix-arg is positive, read the command to start the + process." + (let ((table slime-lisp-implementations)) + (cond ((not current-prefix-arg) (slime-lisp-options)) + ((eq current-prefix-arg '-) + (let ((key (completing-read + "Lisp name: " (mapcar (lambda (x) + (list (symbol-name (car x)))) + table) + nil t))) + (slime-lookup-lisp-implementation table (intern key)))) + (t + (cl-destructuring-bind (program &rest program-args) + (split-string-and-unquote + (read-shell-command "Run lisp: " inferior-lisp-program + 'slime-inferior-lisp-program-history)) + (let ((coding-system + (if (eq 16 (prefix-numeric-value current-prefix-arg)) + (read-coding-system "set slime-coding-system: " + slime-net-coding-system) + slime-net-coding-system))) + (list :program program :program-args program-args + :coding-system coding-system))))))) + +(defun slime-lisp-options (&optional name) + (let ((table slime-lisp-implementations)) + (cl-assert (or (not name) table)) + (cond (table (slime-lookup-lisp-implementation slime-lisp-implementations + (or name slime-default-lisp + (car (car table))))) + (t (cl-destructuring-bind (program &rest args) + (split-string inferior-lisp-program) + (list :program program :program-args args)))))) + +(defun slime-lookup-lisp-implementation (table name) + (let ((arguments (cl-rest (assoc name table)))) + (unless arguments + (error "Could not find lisp implementation with the name '%S'" name)) + (when (and (= (length arguments) 1) + (functionp (cl-first arguments))) + (setf arguments (funcall (cl-first arguments)))) + (cl-destructuring-bind ((prog &rest args) &rest keys) arguments + (cl-list* :name name :program prog :program-args args keys)))) + +(cl-defun slime-start (&key (program inferior-lisp-program) program-args + directory + (coding-system slime-net-coding-system) + (init 'slime-init-command) + name + (buffer "*inferior-lisp*") + init-function + env) + "Start a Lisp process and connect to it. +This function is intended for programmatic use if `slime' is not +flexible enough. + +PROGRAM and PROGRAM-ARGS are the filename and argument strings + for the subprocess. +INIT is a function that should return a string to load and start + Swank. The function will be called with the PORT-FILENAME and ENCODING as + arguments. INIT defaults to `slime-init-command'. +CODING-SYSTEM a symbol for the coding system. The default is + slime-net-coding-system +ENV environment variables for the subprocess (see `process-environment'). +INIT-FUNCTION function to call right after the connection is established. +BUFFER the name of the buffer to use for the subprocess. +NAME a symbol to describe the Lisp implementation +DIRECTORY change to this directory before starting the process. +" + (let ((args (list :program program :program-args program-args :buffer buffer + :coding-system coding-system :init init :name name + :init-function init-function :env env))) + (slime-check-coding-system coding-system) + (when (slime-bytecode-stale-p) + (slime-urge-bytecode-recompile)) + (let ((proc (slime-maybe-start-lisp program program-args env + directory buffer))) + (slime-inferior-connect proc args) + (pop-to-buffer (process-buffer proc))))) + +(defun slime-start* (options) + (apply #'slime-start options)) + +(defun slime-connect (host port &optional _coding-system interactive-p) + "Connect to a running Swank server. Return the connection." + (interactive (list (read-from-minibuffer + "Host: " (cl-first slime-connect-host-history) + nil nil '(slime-connect-host-history . 1)) + (string-to-number + (read-from-minibuffer + "Port: " (cl-first slime-connect-port-history) + nil nil '(slime-connect-port-history . 1))) + nil t)) + (slime-setup) + (when (and interactive-p + slime-net-processes + (y-or-n-p "Close old connections first? ")) + (slime-disconnect-all)) + (message "Connecting to Swank on port %S.." port) + (let* ((process (slime-net-connect host port)) + (slime-dispatching-connection process)) + (slime-setup-connection process))) + +;; FIXME: seems redundant +(defun slime-start-and-init (options fun) + (let* ((rest (plist-get options :init-function)) + (init (cond (rest `(lambda () (funcall ',rest) (funcall ',fun))) + (t fun)))) + (slime-start* (plist-put (cl-copy-list options) :init-function init)))) + +;;;;; Start inferior lisp +;;; +;;; Here is the protocol for starting SLIME: +;;; +;;; 0. Emacs recompiles/reloads slime.elc if it exists and is stale. +;;; 1. Emacs starts an inferior Lisp process. +;;; 2. Emacs tells Lisp (via stdio) to load and start Swank. +;;; 3. Lisp recompiles the Swank if needed. +;;; 4. Lisp starts the Swank server and writes its TCP port to a temp file. +;;; 5. Emacs reads the temp file to get the port and then connects. +;;; 6. Emacs prints a message of warm encouragement for the hacking ahead. +;;; +;;; Between steps 2-5 Emacs polls for the creation of the temp file so +;;; that it can make the connection. This polling may continue for a +;;; fair while if Swank needs recompilation. + +(defvar slime-connect-retry-timer nil + "Timer object while waiting for an inferior-lisp to start.") + +;;; Recompiling bytecode: + +(defun slime-bytecode-stale-p () + "Return true if slime.elc is older than slime.el." + (let ((libfile (locate-library "slime"))) + (when libfile + (let* ((basename (file-name-sans-extension libfile)) + (sourcefile (concat basename ".el")) + (bytefile (concat basename ".elc"))) + (and (file-exists-p bytefile) + (file-newer-than-file-p sourcefile bytefile)))))) + +(defun slime-recompile-bytecode () + "Recompile and reload slime." + (interactive) + (let ((sourcefile (concat (file-name-sans-extension (locate-library "slime")) + ".el"))) + (byte-compile-file sourcefile t))) + +(defun slime-urge-bytecode-recompile () + "Urge the user to recompile slime.elc. +Return true if we have been given permission to continue." + (when (y-or-n-p "slime.elc is older than source. Recompile first? ") + (slime-recompile-bytecode))) + +(defun slime-abort-connection () + "Abort connection the current connection attempt." + (interactive) + (cond (slime-connect-retry-timer + (slime-cancel-connect-retry-timer) + (message "Cancelled connection attempt.")) + (t (error "Not connecting")))) + +;;; Starting the inferior Lisp and loading Swank: + +(defun slime-maybe-start-lisp (program program-args env directory buffer) + "Return a new or existing inferior lisp process." + (cond ((not (comint-check-proc buffer)) + (slime-start-lisp program program-args env directory buffer)) + ((slime-reinitialize-inferior-lisp-p program program-args env buffer) + (let ((conn (cl-find (get-buffer-process buffer) + slime-net-processes + :key #'slime-inferior-process))) + (when conn + (slime-net-close conn))) + (get-buffer-process buffer)) + (t (slime-start-lisp program program-args env directory + (generate-new-buffer-name buffer))))) + +(defun slime-reinitialize-inferior-lisp-p (program program-args env buffer) + (let ((args (slime-inferior-lisp-args (get-buffer-process buffer)))) + (and (equal (plist-get args :program) program) + (equal (plist-get args :program-args) program-args) + (equal (plist-get args :env) env) + (not (y-or-n-p "Create an additional *inferior-lisp*? "))))) + +(defvar slime-inferior-process-start-hook nil + "Hook called whenever a new process gets started.") + +(defun slime-start-lisp (program program-args env directory buffer) + "Does the same as `inferior-lisp' but less ugly. +Return the created process." + (with-current-buffer (get-buffer-create buffer) + (when directory + (cd (expand-file-name directory))) + (comint-mode) + (let ((process-environment (append env process-environment)) + (process-connection-type nil)) + (comint-exec (current-buffer) "inferior-lisp" program nil program-args)) + (lisp-mode-variables t) + (let ((proc (get-buffer-process (current-buffer)))) + (slime-set-query-on-exit-flag proc) + (run-hooks 'slime-inferior-process-start-hook) + proc))) + +(defun slime-inferior-connect (process args) + "Start a Swank server in the inferior Lisp and connect." + (slime-delete-swank-port-file 'quiet) + (slime-start-swank-server process args) + (slime-read-port-and-connect process)) + +(defvar slime-inferior-lisp-args nil + "A buffer local variable in the inferior proccess. +See `slime-start'.") + +(defun slime-start-swank-server (process args) + "Start a Swank server on the inferior lisp." + (cl-destructuring-bind (&key coding-system init &allow-other-keys) args + (with-current-buffer (process-buffer process) + (make-local-variable 'slime-inferior-lisp-args) + (setq slime-inferior-lisp-args args) + (let ((str (funcall init (slime-swank-port-file) coding-system))) + (goto-char (process-mark process)) + (insert-before-markers str) + (process-send-string process str))))) + +(defun slime-inferior-lisp-args (process) + "Return the initial process arguments. +See `slime-start'." + (with-current-buffer (process-buffer process) + slime-inferior-lisp-args)) + +;; XXX load-server & start-server used to be separated. maybe that was better. +(defun slime-init-command (port-filename _coding-system) + "Return a string to initialize Lisp." + (let ((loader (if (file-name-absolute-p slime-backend) + slime-backend + (concat slime-path slime-backend)))) + ;; Return a single form to avoid problems with buffered input. + (format "%S\n\n" + `(progn + (load ,(slime-to-lisp-filename (expand-file-name loader)) + :verbose t) + (funcall (read-from-string "swank-loader:init")) + (funcall (read-from-string "swank:start-server") + ,(slime-to-lisp-filename port-filename)))))) + +(defun slime-swank-port-file () + "Filename where the SWANK server writes its TCP port number." + (expand-file-name (format "slime.%S" (emacs-pid)) (slime-temp-directory))) + +(defun slime-temp-directory () + (cond ((fboundp 'temp-directory) (temp-directory)) + ((boundp 'temporary-file-directory) temporary-file-directory) + (t "/tmp/"))) + +(defun slime-delete-swank-port-file (&optional quiet) + (condition-case data + (delete-file (slime-swank-port-file)) + (error + (cl-ecase quiet + ((nil) (signal (car data) (cdr data))) + (quiet) + (message (message "Unable to delete swank port file %S" + (slime-swank-port-file))))))) + +(defun slime-read-port-and-connect (inferior-process) + (slime-attempt-connection inferior-process nil 1)) + +(defun slime-attempt-connection (process retries attempt) + ;; A small one-state machine to attempt a connection with + ;; timer-based retries. + (slime-cancel-connect-retry-timer) + (let ((file (slime-swank-port-file))) + (unless (active-minibuffer-window) + (message "Polling %S .. %d (Abort with `M-x slime-abort-connection'.)" + file attempt)) + (cond ((and (file-exists-p file) + (> (nth 7 (file-attributes file)) 0)) ; file size + (let ((port (slime-read-swank-port)) + (args (slime-inferior-lisp-args process))) + (slime-delete-swank-port-file 'message) + (let ((c (slime-connect slime-lisp-host port + (plist-get args :coding-system)))) + (slime-set-inferior-process c process)))) + ((and retries (zerop retries)) + (message "Gave up connecting to Swank after %d attempts." attempt)) + ((eq (process-status process) 'exit) + (message "Failed to connect to Swank: inferior process exited.")) + (t + (when (and (file-exists-p file) + (zerop (nth 7 (file-attributes file)))) + (message "(Zero length port file)") + ;; the file may be in the filesystem but not yet written + (unless retries (setq retries 3))) + (cl-assert (not slime-connect-retry-timer)) + (setq slime-connect-retry-timer + (run-with-timer + 0.3 nil + #'slime-timer-call #'slime-attempt-connection + process (and retries (1- retries)) + (1+ attempt))))))) + +(defun slime-timer-call (fun &rest args) + "Call function FUN with ARGS, reporting all errors. + +The default condition handler for timer functions (see +`timer-event-handler') ignores errors." + (condition-case data + (apply fun args) + ((debug error) + (debug nil (list "Error in timer" fun args data))))) + +(defun slime-cancel-connect-retry-timer () + (when slime-connect-retry-timer + (cancel-timer slime-connect-retry-timer) + (setq slime-connect-retry-timer nil))) + +(defun slime-read-swank-port () + "Read the Swank server port number from the `slime-swank-port-file'." + (save-excursion + (with-temp-buffer + (insert-file-contents (slime-swank-port-file)) + (goto-char (point-min)) + (let ((port (read (current-buffer)))) + (cl-assert (integerp port)) + port)))) + +(defun slime-toggle-debug-on-swank-error () + (interactive) + (if (slime-eval `(swank:toggle-debug-on-swank-error)) + (message "Debug on SWANK error enabled.") + (message "Debug on SWANK error disabled."))) + +;;; Words of encouragement + +(defun slime-user-first-name () + (let ((name (if (string= (user-full-name) "") + (user-login-name) + (user-full-name)))) + (string-match "^[^ ]*" name) + (capitalize (match-string 0 name)))) + +(defvar slime-words-of-encouragement + `("Let the hacking commence!" + "Hacks and glory await!" + "Hack and be merry!" + "Your hacking starts... NOW!" + "May the source be with you!" + "Take this REPL, brother, and may it serve you well." + "Lemonodor-fame is but a hack away!" + ,(format "%s, this could be the start of a beautiful program." + (slime-user-first-name))) + "Scientifically-proven optimal words of hackerish encouragement.") + +(defun slime-random-words-of-encouragement () + "Return a string of hackerish encouragement." + (eval (nth (random (length slime-words-of-encouragement)) + slime-words-of-encouragement))) + + +;;;; Networking +;;; +;;; This section covers the low-level networking: establishing +;;; connections and encoding/decoding protocol messages. +;;; +;;; Each SLIME protocol message beings with a 6-byte header followed +;;; by an S-expression as text. The sexp must be readable both by +;;; Emacs and by Common Lisp, so if it contains any embedded code +;;; fragments they should be sent as strings: +;;; +;;; The set of meaningful protocol messages are not specified +;;; here. They are defined elsewhere by the event-dispatching +;;; functions in this file and in swank.lisp. + +(defvar slime-net-processes nil + "List of processes (sockets) connected to Lisps.") + +(defvar slime-net-process-close-hooks '() + "List of functions called when a slime network connection closes. +The functions are called with the process as their argument.") + +(defun slime-secret () + "Find the magic secret from the user's home directory. +Return nil if the file doesn't exist or is empty; otherwise the +first line of the file." + (condition-case _err + (with-temp-buffer + (insert-file-contents "~/.slime-secret") + (goto-char (point-min)) + (buffer-substring (point-min) (line-end-position))) + (file-error nil))) + +;;; Interface +(defun slime-net-connect (host port) + "Establish a connection with a CL." + (let* ((inhibit-quit nil) + (proc (open-network-stream "SLIME Lisp" nil host port)) + (buffer (slime-make-net-buffer " *cl-connection*"))) + (push proc slime-net-processes) + (set-process-buffer proc buffer) + (set-process-filter proc 'slime-net-filter) + (set-process-sentinel proc 'slime-net-sentinel) + (slime-set-query-on-exit-flag proc) + (when (fboundp 'set-process-coding-system) + (set-process-coding-system proc 'binary 'binary)) + (let ((secret (slime-secret))) + (when secret + (slime-net-send secret proc))) + proc)) + +(defun slime-make-net-buffer (name) + "Make a buffer suitable for a network process." + (let ((buffer (generate-new-buffer name))) + (with-current-buffer buffer + (buffer-disable-undo) + (set (make-local-variable 'kill-buffer-query-functions) nil)) + buffer)) + +(defun slime-set-query-on-exit-flag (process) + "Set PROCESS's query-on-exit-flag to `slime-kill-without-query-p'." + (when slime-kill-without-query-p + ;; avoid byte-compiler warnings + (let ((fun (if (fboundp 'set-process-query-on-exit-flag) + 'set-process-query-on-exit-flag + 'process-kill-without-query))) + (funcall fun process nil)))) + +;;;;; Coding system madness + +(defun slime-check-coding-system (coding-system) + "Signal an error if CODING-SYSTEM isn't a valid coding system." + (interactive) + (let ((props (slime-find-coding-system coding-system))) + (unless props + (error "Invalid slime-net-coding-system: %s. %s" + coding-system (mapcar #'car slime-net-valid-coding-systems))) + (when (and (cl-second props) (boundp 'default-enable-multibyte-characters)) + (cl-assert default-enable-multibyte-characters)) + t)) + +(defun slime-coding-system-mulibyte-p (coding-system) + (cl-second (slime-find-coding-system coding-system))) + +(defun slime-coding-system-cl-name (coding-system) + (cl-third (slime-find-coding-system coding-system))) + +;;; Interface +(defun slime-net-send (sexp proc) + "Send a SEXP to Lisp over the socket PROC. +This is the lowest level of communication. The sexp will be READ and +EVAL'd by Lisp." + (let* ((payload (encode-coding-string + (concat (slime-prin1-to-string sexp) "\n") + 'utf-8-unix)) + (string (concat (slime-net-encode-length (length payload)) + payload))) + (slime-log-event sexp) + (process-send-string proc string))) + +(defun slime-safe-encoding-p (coding-system string) + "Return true iff CODING-SYSTEM can safely encode STRING." + (or (let ((candidates (find-coding-systems-string string)) + (base (coding-system-base coding-system))) + (or (equal candidates '(undecided)) + (memq base candidates))) + (and (not (multibyte-string-p string)) + (not (slime-coding-system-mulibyte-p coding-system))))) + +(defun slime-net-close (process &optional debug) + (setq slime-net-processes (remove process slime-net-processes)) + (when (eq process slime-default-connection) + (setq slime-default-connection nil)) + (cond (debug + (set-process-sentinel process 'ignore) + (set-process-filter process 'ignore) + (delete-process process)) + (t + (run-hook-with-args 'slime-net-process-close-hooks process) + ;; killing the buffer also closes the socket + (kill-buffer (process-buffer process))))) + +(defun slime-net-sentinel (process message) + (message "Lisp connection closed unexpectedly: %s" message) + (slime-net-close process)) + +;;; Socket input is handled by `slime-net-filter', which decodes any +;;; complete messages and hands them off to the event dispatcher. + +(defun slime-net-filter (process string) + "Accept output from the socket and process all complete messages." + (with-current-buffer (process-buffer process) + (goto-char (point-max)) + (insert string)) + (slime-process-available-input process)) + +(defun slime-process-available-input (process) + "Process all complete messages that have arrived from Lisp." + (with-current-buffer (process-buffer process) + (while (slime-net-have-input-p) + (let ((event (slime-net-read-or-lose process)) + (ok nil)) + (slime-log-event event) + (unwind-protect + (save-current-buffer + (slime-dispatch-event event process) + (setq ok t)) + (unless ok + (slime-run-when-idle 'slime-process-available-input process))))))) + +(defun slime-net-have-input-p () + "Return true if a complete message is available." + (goto-char (point-min)) + (and (>= (buffer-size) 6) + (>= (- (buffer-size) 6) (slime-net-decode-length)))) + +(defun slime-run-when-idle (function &rest args) + "Call FUNCTION as soon as Emacs is idle." + (apply #'run-at-time 0 nil function args)) + +(defun slime-handle-net-read-error (error) + (let ((packet (buffer-string))) + (slime-with-popup-buffer ((slime-buffer-name :error)) + (princ (format "%s\nin packet:\n%s" (error-message-string error) packet)) + (goto-char (point-min))) + (cond ((y-or-n-p "Skip this packet? ") + `(:emacs-skipped-packet ,packet)) + (t + (when (y-or-n-p "Enter debugger instead? ") + (debug 'error error)) + (signal (car error) (cdr error)))))) + +(defun slime-net-read-or-lose (process) + (condition-case error + (slime-net-read) + (error + (slime-net-close process t) + (error "net-read error: %S" error)))) + +(defun slime-net-read () + "Read a message from the network buffer." + (goto-char (point-min)) + (let* ((length (slime-net-decode-length)) + (start (+ (point) 6)) + (end (+ start length))) + (cl-assert (cl-plusp length)) + (prog1 (save-restriction + (narrow-to-region start end) + (condition-case error + (progn + (decode-coding-region start end 'utf-8-unix) + (setq end (point-max)) + (read (current-buffer))) + (error + (slime-handle-net-read-error error)))) + (delete-region (point-min) end)))) + +(defun slime-net-decode-length () + (string-to-number (buffer-substring-no-properties (point) (+ (point) 6)) + 16)) + +(defun slime-net-encode-length (n) + (format "%06x" n)) + +(defun slime-prin1-to-string (sexp) + "Like `prin1-to-string' but don't octal-escape non-ascii characters. +This is more compatible with the CL reader." + (let (print-escape-nonascii + print-escape-newlines + print-length + print-level) + (prin1-to-string sexp))) + + +;;;; Connections +;;; +;;; "Connections" are the high-level Emacs<->Lisp networking concept. +;;; +;;; Emacs has a connection to each Lisp process that it's interacting +;;; with. Typically there would only be one, but a user can choose to +;;; connect to many Lisps simultaneously. +;;; +;;; A connection consists of a control socket, optionally an extra +;;; socket dedicated to receiving Lisp output (an optimization), and a +;;; set of connection-local state variables. +;;; +;;; The state variables are stored as buffer-local variables in the +;;; control socket's process-buffer and are used via accessor +;;; functions. These variables include things like the *FEATURES* list +;;; and Unix Pid of the Lisp process. +;;; +;;; One connection is "current" at any given time. This is: +;;; `slime-dispatching-connection' if dynamically bound, or +;;; `slime-buffer-connection' if this is set buffer-local, or +;;; `slime-default-connection' otherwise. +;;; +;;; When you're invoking commands in your source files you'll be using +;;; `slime-default-connection'. This connection can be interactively +;;; reassigned via the connection-list buffer. +;;; +;;; When a command creates a new buffer it will set +;;; `slime-buffer-connection' so that commands in the new buffer will +;;; use the connection that the buffer originated from. For example, +;;; the apropos command creates the *Apropos* buffer and any command +;;; in that buffer (e.g. `M-.') will go to the same Lisp that did the +;;; apropos search. REPL buffers are similarly tied to their +;;; respective connections. +;;; +;;; When Emacs is dispatching some network message that arrived from a +;;; connection it will dynamically bind `slime-dispatching-connection' +;;; so that the event will be processed in the context of that +;;; connection. +;;; +;;; This is mostly transparent. The user should be aware that he can +;;; set the default connection to pick which Lisp handles commands in +;;; Lisp-mode source buffers, and slime hackers should be aware that +;;; they can tie a buffer to a specific connection. The rest takes +;;; care of itself. + +(defvar slime-dispatching-connection nil + "Network process currently executing. +This is dynamically bound while handling messages from Lisp; it +overrides `slime-buffer-connection' and `slime-default-connection'.") + +(make-variable-buffer-local + (defvar slime-buffer-connection nil + "Network connection to use in the current buffer. +This overrides `slime-default-connection'.")) + +(defvar slime-default-connection nil + "Network connection to use by default. +Used for all Lisp communication, except when overridden by +`slime-dispatching-connection' or `slime-buffer-connection'.") + +(defun slime-current-connection () + "Return the connection to use for Lisp interaction. +Return nil if there's no connection." + (or slime-dispatching-connection + slime-buffer-connection + slime-default-connection)) + +(defun slime-connection () + "Return the connection to use for Lisp interaction. +Signal an error if there's no connection." + (let ((conn (slime-current-connection))) + (cond ((and (not conn) slime-net-processes) + (or (slime-auto-select-connection) + (error "No default connection selected."))) + ((not conn) + (or (slime-auto-start) + (error "Not connected."))) + ((not (eq (process-status conn) 'open)) + (error "Connection closed.")) + (t conn)))) + +(define-obsolete-variable-alias 'slime-auto-connect +'slime-auto-start "2.5") +(defcustom slime-auto-start 'never + "Controls auto connection when information from lisp process is needed. +This doesn't mean it will connect right after Slime is loaded." + :group 'slime-mode + :type '(choice (const never) + (const always) + (const ask))) + +(defun slime-auto-start () + (cond ((or (eq slime-auto-start 'always) + (and (eq slime-auto-start 'ask) + (y-or-n-p "No connection. Start Slime? "))) + (save-window-excursion + (slime) + (while (not (slime-current-connection)) + (sleep-for 1)) + (slime-connection))) + (t nil))) + +(defcustom slime-auto-select-connection 'ask + "Controls auto selection after the default connection was closed." + :group 'slime-mode + :type '(choice (const never) + (const always) + (const ask))) + +(defun slime-auto-select-connection () + (let* ((c0 (car slime-net-processes)) + (c (cond ((eq slime-auto-select-connection 'always) c0) + ((and (eq slime-auto-select-connection 'ask) + (y-or-n-p + (format "No default connection selected. %s %s? " + "Switch to" (slime-connection-name c0)))) + c0)))) + (when c + (slime-select-connection c) + (message "Switching to connection: %s" (slime-connection-name c)) + c))) + +(defun slime-select-connection (process) + "Make PROCESS the default connection." + (setq slime-default-connection process)) + +(defvar slime-cycle-connections-hook nil) + +(defun slime-cycle-connections-within (connections) + (let* ((tail (or (cdr (member (slime-current-connection) connections)) + connections)) ; loop around to the beginning + (next (car tail))) + (slime-select-connection next) + (run-hooks 'slime-cycle-connections-hook) + (message "Lisp: %s %s" + (slime-connection-name next) + (process-contact next)))) + +(defun slime-next-connection () + "Change current slime connection, cycling through all connections." + (interactive) + (slime-cycle-connections-within (reverse slime-net-processes))) + +(define-obsolete-function-alias 'slime-cycle-connections + 'slime-next-connection "2.13") + +(defun slime-prev-connection () + "Change current slime connection, cycling through all connections. +Goes in reverse order, relative to `slime-next-connection'." + (interactive) + (slime-cycle-connections-within slime-net-processes)) + +(cl-defmacro slime-with-connection-buffer ((&optional process) &rest body) + "Execute BODY in the process-buffer of PROCESS. +If PROCESS is not specified, `slime-connection' is used. + +\(fn (&optional PROCESS) &body BODY))" + (declare (indent 1)) + `(with-current-buffer + (process-buffer (or ,process (slime-connection) + (error "No connection"))) + ,@body)) + +;;; Connection-local variables: + +(defmacro slime-def-connection-var (varname &rest initial-value-and-doc) + "Define a connection-local variable. +The value of the variable can be read by calling the function of the +same name (it must not be accessed directly). The accessor function is +setf-able. + +The actual variable bindings are stored buffer-local in the +process-buffers of connections. The accessor function refers to +the binding for `slime-connection'." + (declare (indent 2)) + (let ((real-var (intern (format "%s:connlocal" varname)))) + `(progn + ;; Variable + (make-variable-buffer-local + (defvar ,real-var ,@initial-value-and-doc)) + ;; Accessor + (defun ,varname (&optional process) + (slime-with-connection-buffer (process) ,real-var)) + ;; Setf + (defsetf ,varname (&optional process) (store) + `(slime-with-connection-buffer (,process) + (setq (\, (quote (\, real-var))) (\, store)))) + '(\, varname)))) + +(slime-def-connection-var slime-connection-number nil + "Serial number of a connection. +Bound in the connection's process-buffer.") + +(slime-def-connection-var slime-lisp-features '() + "The symbol-names of Lisp's *FEATURES*. +This is automatically synchronized from Lisp.") + +(slime-def-connection-var slime-lisp-modules '() + "The strings of Lisp's *MODULES*.") + +(slime-def-connection-var slime-pid nil + "The process id of the Lisp process.") + +(slime-def-connection-var slime-lisp-implementation-type nil + "The implementation type of the Lisp process.") + +(slime-def-connection-var slime-lisp-implementation-version nil + "The implementation type of the Lisp process.") + +(slime-def-connection-var slime-lisp-implementation-name nil + "The short name for the Lisp implementation.") + +(slime-def-connection-var slime-lisp-implementation-program nil + "The argv[0] of the process running the Lisp implementation.") + +(slime-def-connection-var slime-connection-name nil + "The short name for connection.") + +(slime-def-connection-var slime-inferior-process nil + "The inferior process for the connection if any.") + +(slime-def-connection-var slime-communication-style nil + "The communication style.") + +(slime-def-connection-var slime-machine-instance nil + "The name of the (remote) machine running the Lisp process.") + +(slime-def-connection-var slime-connection-coding-systems nil + "Coding systems supported by the Lisp process.") + +;;;;; Connection setup + +(defvar slime-connection-counter 0 + "The number of SLIME connections made. For generating serial numbers.") + +;;; Interface +(defun slime-setup-connection (process) + "Make a connection out of PROCESS." + (let ((slime-dispatching-connection process)) + (slime-init-connection-state process) + (slime-select-connection process) + process)) + +(defun slime-init-connection-state (proc) + "Initialize connection state in the process-buffer of PROC." + ;; To make life simpler for the user: if this is the only open + ;; connection then reset the connection counter. + (when (equal slime-net-processes (list proc)) + (setq slime-connection-counter 0)) + (slime-with-connection-buffer () + (setq slime-buffer-connection proc)) + (setf (slime-connection-number proc) (cl-incf slime-connection-counter)) + ;; We do the rest of our initialization asynchronously. The current + ;; function may be called from a timer, and if we setup the REPL + ;; from a timer then it mysteriously uses the wrong keymap for the + ;; first command. + (let ((slime-current-thread t)) + (slime-eval-async '(swank:connection-info) + (slime-curry #'slime-set-connection-info proc)))) + +(defun slime-set-connection-info (connection info) + "Initialize CONNECTION with INFO received from Lisp." + (let ((slime-dispatching-connection connection) + (slime-current-thread t)) + (cl-destructuring-bind (&key pid style lisp-implementation machine + features version modules encoding + &allow-other-keys) info + (slime-check-version version connection) + (setf (slime-pid) pid + (slime-communication-style) style + (slime-lisp-features) features + (slime-lisp-modules) modules) + (cl-destructuring-bind (&key type name version program) + lisp-implementation + (setf (slime-lisp-implementation-type) type + (slime-lisp-implementation-version) version + (slime-lisp-implementation-name) name + (slime-lisp-implementation-program) program + (slime-connection-name) (slime-generate-connection-name name))) + (cl-destructuring-bind (&key instance ((:type _)) ((:version _))) machine + (setf (slime-machine-instance) instance)) + (cl-destructuring-bind (&key coding-systems) encoding + (setf (slime-connection-coding-systems) coding-systems))) + (let ((args (let ((p (slime-inferior-process))) + (if p (slime-inferior-lisp-args p))))) + (let ((name (plist-get args ':name))) + (when name + (unless (string= (slime-lisp-implementation-name) name) + (setf (slime-connection-name) + (slime-generate-connection-name (symbol-name name)))))) + (slime-load-contribs) + (run-hooks 'slime-connected-hook) + (let ((fun (plist-get args ':init-function))) + (when fun (funcall fun)))) + (message "Connected. %s" (slime-random-words-of-encouragement)))) + +(defun slime-check-version (version conn) + (or (equal version slime-protocol-version) + (equal slime-protocol-version 'ignore) + (y-or-n-p + (format "Versions differ: %s (slime) vs. %s (swank). Continue? " + slime-protocol-version version)) + (slime-net-close conn) + (top-level))) + +(defun slime-generate-connection-name (lisp-name) + (cl-loop for i from 1 + for name = lisp-name then (format "%s<%d>" lisp-name i) + while (cl-find name slime-net-processes + :key #'slime-connection-name :test #'equal) + finally (cl-return name))) + +(defun slime-connection-close-hook (process) + (when (eq process slime-default-connection) + (when slime-net-processes + (slime-select-connection (car slime-net-processes)) + (message "Default connection closed; switched to #%S (%S)" + (slime-connection-number) + (slime-connection-name))))) + +(add-hook 'slime-net-process-close-hooks 'slime-connection-close-hook) + +;;;;; Commands on connections + +(defun slime-disconnect () + "Close the current connection." + (interactive) + (slime-net-close (slime-connection))) + +(defun slime-disconnect-all () + "Disconnect all connections." + (interactive) + (mapc #'slime-net-close slime-net-processes)) + +(defun slime-connection-port (connection) + "Return the remote port number of CONNECTION." + (cadr (process-contact connection))) + +(defun slime-process (&optional connection) + "Return the Lisp process for CONNECTION (default `slime-connection'). +Return nil if there's no process object for the connection." + (let ((proc (slime-inferior-process connection))) + (if (and proc + (memq (process-status proc) '(run stop))) + proc))) + +;; Non-macro version to keep the file byte-compilable. +(defun slime-set-inferior-process (connection process) + (setf (slime-inferior-process connection) process)) + +(defun slime-use-sigint-for-interrupt (&optional connection) + (let ((c (or connection (slime-connection)))) + (cl-ecase (slime-communication-style c) + ((:fd-handler nil) t) + ((:spawn :sigio) nil)))) + +(defvar slime-inhibit-pipelining t + "*If true, don't send background requests if Lisp is already busy.") + +(defun slime-background-activities-enabled-p () + (and (let ((con (slime-current-connection))) + (and con + (eq (process-status con) 'open))) + (or (not (slime-busy-p)) + (not slime-inhibit-pipelining)))) + + +;;;; Communication protocol + +;;;;; Emacs Lisp programming interface +;;; +;;; The programming interface for writing Emacs commands is based on +;;; remote procedure calls (RPCs). The basic operation is to ask Lisp +;;; to apply a named Lisp function to some arguments, then to do +;;; something with the result. +;;; +;;; Requests can be either synchronous (blocking) or asynchronous +;;; (with the result passed to a callback/continuation function). If +;;; an error occurs during the request then the debugger is entered +;;; before the result arrives -- for synchronous evaluations this +;;; requires a recursive edit. +;;; +;;; You should use asynchronous evaluations (`slime-eval-async') for +;;; most things. Reserve synchronous evaluations (`slime-eval') for +;;; the cases where blocking Emacs is really appropriate (like +;;; completion) and that shouldn't trigger errors (e.g. not evaluate +;;; user-entered code). +;;; +;;; We have the concept of the "current Lisp package". RPC requests +;;; always say what package the user is making them from and the Lisp +;;; side binds that package to *BUFFER-PACKAGE* to use as it sees +;;; fit. The current package is defined as the buffer-local value of +;;; `slime-buffer-package' if set, and otherwise the package named by +;;; the nearest IN-PACKAGE as found by text search (cl-first backwards, +;;; then forwards). +;;; +;;; Similarly we have the concept of the current thread, i.e. which +;;; thread in the Lisp process should handle the request. The current +;;; thread is determined solely by the buffer-local value of +;;; `slime-current-thread'. This is usually bound to t meaning "no +;;; particular thread", but can also be used to nominate a specific +;;; thread. The REPL and the debugger both use this feature to deal +;;; with specific threads. + +(make-variable-buffer-local + (defvar slime-current-thread t + "The id of the current thread on the Lisp side. +t means the \"current\" thread; +:repl-thread the thread that executes REPL requests; +fixnum a specific thread.")) + +(make-variable-buffer-local + (defvar slime-buffer-package nil + "The Lisp package associated with the current buffer. +This is set only in buffers bound to specific packages.")) + +;;; `slime-rex' is the RPC primitive which is used to implement both +;;; `slime-eval' and `slime-eval-async'. You can use it directly if +;;; you need to, but the others are usually more convenient. + +(cl-defmacro slime-rex ((&rest saved-vars) + (sexp &optional + (package '(slime-current-package)) + (thread 'slime-current-thread)) + &rest continuations) + "(slime-rex (VAR ...) (SEXP &optional PACKAGE THREAD) CLAUSES ...) + +Remote EXecute SEXP. + +VARs are a list of saved variables visible in the other forms. Each +VAR is either a symbol or a list (VAR INIT-VALUE). + +SEXP is evaluated and the princed version is sent to Lisp. + +PACKAGE is evaluated and Lisp binds *BUFFER-PACKAGE* to this package. +The default value is (slime-current-package). + +CLAUSES is a list of patterns with same syntax as +`slime-dcase'. The result of the evaluation of SEXP is +dispatched on CLAUSES. The result is either a sexp of the +form (:ok VALUE) or (:abort CONDITION). CLAUSES is executed +asynchronously. + +Note: don't use backquote syntax for SEXP, because various Emacs +versions cannot deal with that." + (declare (indent 2)) + (let ((result (cl-gensym))) + `(lexical-let ,(cl-loop for var in saved-vars + collect (cl-etypecase var + (symbol (list var var)) + (cons var))) + (slime-dispatch-event + (list :emacs-rex ,sexp ,package ,thread + (lambda (,result) + (slime-dcase ,result + ,@continuations))))))) + +;;; Interface +(defun slime-current-package () + "Return the Common Lisp package in the current context. +If `slime-buffer-package' has a value then return that, otherwise +search for and read an `in-package' form." + (or slime-buffer-package + (save-restriction + (widen) + (slime-find-buffer-package)))) + +(defvar slime-find-buffer-package-function 'slime-search-buffer-package + "*Function to use for `slime-find-buffer-package'. +The result should be the package-name (a string) +or nil if nothing suitable can be found.") + +(defun slime-find-buffer-package () + "Figure out which Lisp package the current buffer is associated with." + (funcall slime-find-buffer-package-function)) + +(make-variable-buffer-local + (defvar slime-package-cache nil + "Cons of the form (buffer-modified-tick . package)")) + +;; When modifing this code consider cases like: +;; (in-package #.*foo*) +;; (in-package #:cl) +;; (in-package :cl) +;; (in-package "CL") +;; (in-package |CL|) +;; (in-package #+ansi-cl :cl #-ansi-cl 'lisp) + +(defun slime-search-buffer-package () + (let ((case-fold-search t) + (regexp (concat "^(\\(cl:\\|common-lisp:\\)?in-package\\>[ \t']*" + "\\([^)]+\\)[ \t]*)"))) + (save-excursion + (when (or (re-search-backward regexp nil t) + (re-search-forward regexp nil t)) + (match-string-no-properties 2))))) + +;;; Synchronous requests are implemented in terms of asynchronous +;;; ones. We make an asynchronous request with a continuation function +;;; that `throw's its result up to a `catch' and then enter a loop of +;;; handling I/O until that happens. + +(defvar slime-stack-eval-tags nil + "List of stack-tags of continuations waiting on the stack.") + +(defun slime-eval (sexp &optional package) + "Evaluate EXPR on the superior Lisp and return the result." + (when (null package) (setq package (slime-current-package))) + (let* ((tag (cl-gensym (format "slime-result-%d-" + (1+ (slime-continuation-counter))))) + (slime-stack-eval-tags (cons tag slime-stack-eval-tags))) + (apply + #'funcall + (catch tag + (slime-rex (tag sexp) + (sexp package) + ((:ok value) + (unless (member tag slime-stack-eval-tags) + (error "Reply to canceled synchronous eval request tag=%S sexp=%S" + tag sexp)) + (throw tag (list #'identity value))) + ((:abort _condition) + (throw tag (list #'error "Synchronous Lisp Evaluation aborted")))) + (let ((debug-on-quit t) + (inhibit-quit nil) + (conn (slime-connection))) + (while t + (unless (eq (process-status conn) 'open) + (error "Lisp connection closed unexpectedly")) + (accept-process-output nil 0.01))))))) + +(defun slime-eval-async (sexp &optional cont package) + "Evaluate EXPR on the superior Lisp and call CONT with the result." + (declare (indent 1)) + (slime-rex (cont (buffer (current-buffer))) + (sexp (or package (slime-current-package))) + ((:ok result) + (when cont + (set-buffer buffer) + (funcall cont result))) + ((:abort condition) + (message "Evaluation aborted on %s." condition))) + ;; Guard against arbitrary return values which once upon a time + ;; showed up in the minibuffer spuriously (due to a bug in + ;; slime-autodoc.) If this ever happens again, returning the + ;; following will make debugging much easier: + :slime-eval-async) + +;;; These functions can be handy too: + +(defun slime-connected-p () + "Return true if the Swank connection is open." + (not (null slime-net-processes))) + +(defun slime-check-connected () + "Signal an error if we are not connected to Lisp." + (unless (slime-connected-p) + (error "Not connected. Use `%s' to start a Lisp." + (substitute-command-keys "\\[slime]")))) + +;; UNUSED +(defun slime-debugged-connection-p (conn) + ;; This previously was (AND (SLDB-DEBUGGED-CONTINUATIONS CONN) T), + ;; but an SLDB buffer may exist without having continuations + ;; attached to it, e.g. the one resulting from `slime-interrupt'. + (cl-loop for b in (sldb-buffers) + thereis (with-current-buffer b + (eq slime-buffer-connection conn)))) + +(defun slime-busy-p (&optional conn) + "True if Lisp has outstanding requests. +Debugged requests are ignored." + (let ((debugged (sldb-debugged-continuations (or conn (slime-connection))))) + (cl-remove-if (lambda (id) + (memq id debugged)) + (slime-rex-continuations) + :key #'car))) + +(defun slime-sync () + "Block until the most recent request has finished." + (when (slime-rex-continuations) + (let ((tag (caar (slime-rex-continuations)))) + (while (cl-find tag (slime-rex-continuations) :key #'car) + (accept-process-output nil 0.1))))) + +(defun slime-ping () + "Check that communication works." + (interactive) + (message "%s" (slime-eval "PONG"))) + +;;;;; Protocol event handler (cl-the guts) +;;; +;;; This is the protocol in all its glory. The input to this function +;;; is a protocol event that either originates within Emacs or arrived +;;; over the network from Lisp. +;;; +;;; Each event is a list beginning with a keyword and followed by +;;; arguments. The keyword identifies the type of event. Events +;;; originating from Emacs have names starting with :emacs- and events +;;; from Lisp don't. + +(slime-def-connection-var slime-rex-continuations '() + "List of (ID . FUNCTION) continuations waiting for RPC results.") + +(slime-def-connection-var slime-continuation-counter 0 + "Continuation serial number counter.") + +(defvar slime-event-hooks) + +(defun slime-dispatch-event (event &optional process) + (let ((slime-dispatching-connection (or process (slime-connection)))) + (or (run-hook-with-args-until-success 'slime-event-hooks event) + (slime-dcase event + ((:emacs-rex form package thread continuation) + (when (and (slime-use-sigint-for-interrupt) (slime-busy-p)) + (slime-display-oneliner "; pipelined request... %S" form)) + (let ((id (cl-incf (slime-continuation-counter)))) + (slime-send `(:emacs-rex ,form ,package ,thread ,id)) + (push (cons id continuation) (slime-rex-continuations)) + (slime--recompute-modelines))) + ((:return value id) + (let ((rec (assq id (slime-rex-continuations)))) + (cond (rec (setf (slime-rex-continuations) + (remove rec (slime-rex-continuations))) + (slime--recompute-modelines) + (funcall (cdr rec) value)) + (t + (error "Unexpected reply: %S %S" id value))))) + ((:debug-activate thread level &optional select) + (cl-assert thread) + (sldb-activate thread level select)) + ((:debug thread level condition restarts frames conts) + (cl-assert thread) + (sldb-setup thread level condition restarts frames conts)) + ((:debug-return thread level stepping) + (cl-assert thread) + (sldb-exit thread level stepping)) + ((:emacs-interrupt thread) + (slime-send `(:emacs-interrupt ,thread))) + ((:channel-send id msg) + (slime-channel-send (or (slime-find-channel id) + (error "Invalid channel id: %S %S" id msg)) + msg)) + ((:emacs-channel-send id msg) + (slime-send `(:emacs-channel-send ,id ,msg))) + ((:read-from-minibuffer thread tag prompt initial-value) + (slime-read-from-minibuffer-for-swank thread tag prompt + initial-value)) + ((:y-or-n-p thread tag question) + (slime-y-or-n-p thread tag question)) + ((:emacs-return-string thread tag string) + (slime-send `(:emacs-return-string ,thread ,tag ,string))) + ((:new-features features) + (setf (slime-lisp-features) features)) + ((:indentation-update info) + (slime-handle-indentation-update info)) + ((:eval-no-wait form) + (slime-check-eval-in-emacs-enabled) + (eval (read form))) + ((:eval thread tag form-string) + (slime-check-eval-in-emacs-enabled) + (slime-eval-for-lisp thread tag form-string)) + ((:emacs-return thread tag value) + (slime-send `(:emacs-return ,thread ,tag ,value))) + ((:ed what) + (slime-ed what)) + ((:inspect what thread tag) + (let ((hook (when (and thread tag) + (slime-curry #'slime-send + `(:emacs-return ,thread ,tag nil))))) + (slime-open-inspector what nil hook))) + ((:background-message message) + (slime-background-message "%s" message)) + ((:debug-condition thread message) + (cl-assert thread) + (message "%s" message)) + ((:ping thread tag) + (slime-send `(:emacs-pong ,thread ,tag))) + ((:reader-error packet condition) + (slime-with-popup-buffer ((slime-buffer-name :error)) + (princ (format "Invalid protocol message:\n%s\n\n%s" + condition packet)) + (goto-char (point-min))) + (error "Invalid protocol message")) + ((:invalid-rpc id message) + (setf (slime-rex-continuations) + (cl-remove id (slime-rex-continuations) :key #'car)) + (error "Invalid rpc: %s" message)) + ((:emacs-skipped-packet _pkg)) + ((:test-delay seconds) ; for testing only + (sit-for seconds)))))) + +(defun slime-send (sexp) + "Send SEXP directly over the wire on the current connection." + (slime-net-send sexp (slime-connection))) + +(defun slime-reset () + "Clear all pending continuations and erase connection buffer." + (interactive) + (setf (slime-rex-continuations) '()) + (mapc #'kill-buffer (sldb-buffers)) + (slime-with-connection-buffer () + (erase-buffer))) + +(defun slime-send-sigint () + (interactive) + (signal-process (slime-pid) 'SIGINT)) + +;;;;; Channels + +;;; A channel implements a set of operations. Those operations can be +;;; invoked by sending messages to the channel. Channels are used for +;;; protocols which can't be expressed naturally with RPCs, e.g. for +;;; streaming data over the wire. +;;; +;;; A channel can be "remote" or "local". Remote channels are +;;; represented by integers. Local channels are structures. Messages +;;; sent to a closed (remote) channel are ignored. + +(slime-def-connection-var slime-channels '() + "Alist of the form (ID . CHANNEL).") + +(slime-def-connection-var slime-channels-counter 0 + "Channel serial number counter.") + +(cl-defstruct (slime-channel (:conc-name slime-channel.) + (:constructor + slime-make-channel% (operations name id plist))) + operations name id plist) + +(defun slime-make-channel (operations &optional name) + (let* ((id (cl-incf (slime-channels-counter))) + (ch (slime-make-channel% operations name id nil))) + (push (cons id ch) (slime-channels)) + ch)) + +(defun slime-close-channel (channel) + (setf (slime-channel.operations channel) 'closed-channel) + (let ((probe (assq (slime-channel.id channel) (slime-channels)))) + (cond (probe (setf (slime-channels) (delete probe (slime-channels)))) + (t (error "Invalid channel: %s" channel))))) + +(defun slime-find-channel (id) + (cdr (assq id (slime-channels)))) + +(defun slime-channel-send (channel message) + (apply (or (gethash (car message) (slime-channel.operations channel)) + (error "Unsupported operation: %S %S" message channel)) + channel (cdr message))) + +(defun slime-channel-put (channel prop value) + (setf (slime-channel.plist channel) + (plist-put (slime-channel.plist channel) prop value))) + +(defun slime-channel-get (channel prop) + (plist-get (slime-channel.plist channel) prop)) + +(eval-and-compile + (defun slime-channel-method-table-name (type) + (intern (format "slime-%s-channel-methods" type)))) + +(defmacro slime-define-channel-type (name) + (declare (indent defun)) + (let ((tab (slime-channel-method-table-name name))) + `(progn + (defvar ,tab) + (setq ,tab (make-hash-table :size 10))))) + +(defmacro slime-define-channel-method (type method args &rest body) + (declare (indent 3) (debug (&define name sexp lambda-list + def-body))) + `(puthash ',method + (lambda (self . ,args) . ,body) + ,(slime-channel-method-table-name type))) + +(defun slime-send-to-remote-channel (channel-id msg) + (slime-dispatch-event `(:emacs-channel-send ,channel-id ,msg))) + +;;;;; Event logging to *slime-events* +;;; +;;; The *slime-events* buffer logs all protocol messages for debugging +;;; purposes. Optionally you can enable outline-mode in that buffer, +;;; which is convenient but slows things down significantly. + +(defvar slime-log-events t + "*Log protocol events to the *slime-events* buffer.") + +(defvar slime-outline-mode-in-events-buffer nil + "*Non-nil means use outline-mode in *slime-events*.") + +(defvar slime-event-buffer-name (slime-buffer-name :events) + "The name of the slime event buffer.") + +(defun slime-log-event (event) + "Record the fact that EVENT occurred." + (when slime-log-events + (with-current-buffer (slime-events-buffer) + ;; trim? + (when (> (buffer-size) 100000) + (goto-char (/ (buffer-size) 2)) + (re-search-forward "^(" nil t) + (delete-region (point-min) (point))) + (goto-char (point-max)) + (save-excursion + (slime-pprint-event event (current-buffer))) + (when (and (boundp 'outline-minor-mode) + outline-minor-mode) + (hide-entry)) + (goto-char (point-max))))) + +(defun slime-pprint-event (event buffer) + "Pretty print EVENT in BUFFER with limited depth and width." + (let ((print-length 20) + (print-level 6) + (pp-escape-newlines t)) + (pp event buffer))) + +(defun slime-events-buffer () + "Return or create the event log buffer." + (or (get-buffer slime-event-buffer-name) + (let ((buffer (get-buffer-create slime-event-buffer-name))) + (with-current-buffer buffer + (buffer-disable-undo) + (set (make-local-variable 'outline-regexp) "^(") + (set (make-local-variable 'comment-start) ";") + (set (make-local-variable 'comment-end) "") + (when slime-outline-mode-in-events-buffer + (outline-minor-mode))) + buffer))) + + +;;;;; Cleanup after a quit + +(defun slime-restart-inferior-lisp () + "Kill and restart the Lisp subprocess." + (interactive) + (cl-assert (slime-inferior-process) () "No inferior lisp process") + (slime-quit-lisp-internal (slime-connection) 'slime-restart-sentinel t)) + +(defun slime-restart-sentinel (process _message) + "Restart the inferior lisp process. +Also rearrange windows." + (cl-assert (process-status process) 'closed) + (let* ((proc (slime-inferior-process process)) + (args (slime-inferior-lisp-args proc)) + (buffer (buffer-name (process-buffer proc))) + ;;(buffer-window (get-buffer-window buffer)) + (new-proc (slime-start-lisp (plist-get args :program) + (plist-get args :program-args) + (plist-get args :env) + nil + buffer))) + (slime-net-close process) + (slime-inferior-connect new-proc args) + (switch-to-buffer buffer) + (goto-char (point-max)))) + + +;;;; Compilation and the creation of compiler-note annotations + +(defvar slime-highlight-compiler-notes t + "*When non-nil annotate buffers with compilation notes etc.") + +(defvar slime-before-compile-functions nil + "A list of function called before compiling a buffer or region. +The function receive two arguments: the beginning and the end of the +region that will be compiled.") + +;; FIXME: remove some of the options +(defcustom slime-compilation-finished-hook 'slime-maybe-show-compilation-log + "Hook called with a list of compiler notes after a compilation." + :group 'slime-mode + :type 'hook + :options '(slime-maybe-show-compilation-log + slime-create-compilation-log + slime-show-compilation-log + slime-maybe-list-compiler-notes + slime-list-compiler-notes + slime-maybe-show-xrefs-for-notes + slime-goto-first-note)) + +;; FIXME: I doubt that anybody uses this directly and it seems to be +;; only an ugly way to pass arguments. +(defvar slime-compilation-policy nil + "When non-nil compile with these optimization settings.") + +(defun slime-compute-policy (arg) + "Return the policy for the prefix argument ARG." + (let ((between (lambda (min n max) + (cond ((< n min) min) + ((> n max) max) + (t n))))) + (let ((n (prefix-numeric-value arg))) + (cond ((not arg) slime-compilation-policy) + ((cl-plusp n) `((cl:debug . ,(funcall between 0 n 3)))) + ((eq arg '-) `((cl:speed . 3))) + (t `((cl:speed . ,(funcall between 0 (abs n) 3)))))))) + +(cl-defstruct (slime-compilation-result + (:type list) + (:conc-name slime-compilation-result.) + (:constructor nil) + (:copier nil)) + tag notes successp duration loadp faslfile) + +(defvar slime-last-compilation-result nil + "The result of the most recently issued compilation.") + +(defun slime-compiler-notes () + "Return all compiler notes, warnings, and errors." + (slime-compilation-result.notes slime-last-compilation-result)) + +(defun slime-compile-and-load-file (&optional policy) + "Compile and load the buffer's file and highlight compiler notes. + +With (positive) prefix argument the file is compiled with maximal +debug settings (`C-u'). With negative prefix argument it is compiled for +speed (`M--'). If a numeric argument is passed set debug or speed settings +to it depending on its sign. + +Each source location that is the subject of a compiler note is +underlined and annotated with the relevant information. The commands +`slime-next-note' and `slime-previous-note' can be used to navigate +between compiler notes and to display their full details." + (interactive "P") + (slime-compile-file t (slime-compute-policy policy))) + +(defcustom slime-compile-file-options '() + "Plist of additional options that C-c C-k should pass to Lisp. +Currently only :fasl-directory is supported." + :group 'slime-lisp + :type '(plist :key-type symbol :value-type (file :must-match t))) + +(defun slime-compile-file (&optional load policy) + "Compile current buffer's file and highlight resulting compiler notes. + +See `slime-compile-and-load-file' for further details." + (interactive) + (unless buffer-file-name + (error "Buffer %s is not associated with a file." (buffer-name))) + (check-parens) + (slime--maybe-save-buffer) + (run-hook-with-args 'slime-before-compile-functions (point-min) (point-max)) + (let ((file (slime-to-lisp-filename (buffer-file-name))) + (options (slime-simplify-plist `(,@slime-compile-file-options + :policy ,policy)))) + (slime-eval-async + `(swank:compile-file-for-emacs ,file ,(if load t nil) + . ,(slime-hack-quotes options)) + #'slime-compilation-finished) + (message "Compiling %s..." file))) + +;; FIXME: compilation-save-buffers-predicate was introduced in 24.1 +(defun slime--maybe-save-buffer () + (let ((slime--this-buffer (current-buffer))) + (save-some-buffers (not compilation-ask-about-save) + (lambda () (eq (current-buffer) slime--this-buffer))))) + +(defun slime-hack-quotes (arglist) + ;; eval is the wrong primitive, we really want funcall + (cl-loop for arg in arglist collect `(quote ,arg))) + +(defun slime-simplify-plist (plist) + (cl-loop for (key val) on plist by #'cddr + append (cond ((null val) '()) + (t (list key val))))) + +(defun slime-compile-defun (&optional raw-prefix-arg) + "Compile the current toplevel form. + +With (positive) prefix argument the form is compiled with maximal +debug settings (`C-u'). With negative prefix argument it is compiled for +speed (`M--'). If a numeric argument is passed set debug or speed settings +to it depending on its sign." + (interactive "P") + (let ((slime-compilation-policy (slime-compute-policy raw-prefix-arg))) + (if (use-region-p) + (slime-compile-region (region-beginning) (region-end)) + (apply #'slime-compile-region (slime-region-for-defun-at-point))))) + +(defun slime-compile-region (start end) + "Compile the region." + (interactive "r") + ;; Check connection before running hooks things like + ;; slime-flash-region don't make much sense if there's no connection + (slime-connection) + (slime-flash-region start end) + (run-hook-with-args 'slime-before-compile-functions start end) + (slime-compile-string (buffer-substring-no-properties start end) start)) + +(defun slime-flash-region (start end &optional timeout) + "Temporarily highlight region from START to END." + (let ((overlay (make-overlay start end))) + (overlay-put overlay 'face 'secondary-selection) + (run-with-timer (or timeout 0.2) nil 'delete-overlay overlay))) + +(defun slime-compile-string (string start-offset) + (let* ((line (save-excursion + (goto-char start-offset) + (list (line-number-at-pos) (1+ (current-column))))) + (position `((:position ,start-offset) (:line ,@line)))) + (slime-eval-async + `(swank:compile-string-for-emacs + ,string + ,(buffer-name) + ',position + ,(if (buffer-file-name) (slime-to-lisp-filename (buffer-file-name))) + ',slime-compilation-policy) + #'slime-compilation-finished))) + +(defcustom slime-load-failed-fasl 'ask + "Which action to take when COMPILE-FILE set FAILURE-P to T. +NEVER doesn't load the fasl +ALWAYS loads the fasl +ASK asks the user." + :type '(choice (const never) + (const always) + (const ask))) + +(defun slime-load-failed-fasl-p () + (cl-ecase slime-load-failed-fasl + (never nil) + (always t) + (ask (y-or-n-p "Compilation failed. Load fasl file anyway? ")))) + +(defun slime-compilation-finished (result) + (with-struct (slime-compilation-result. notes duration successp + loadp faslfile) result + (setf slime-last-compilation-result result) + (slime-show-note-counts notes duration (cond ((not loadp) successp) + (t (and faslfile successp)))) + (when slime-highlight-compiler-notes + (slime-highlight-notes notes)) + (run-hook-with-args 'slime-compilation-finished-hook notes) + (when (and loadp faslfile + (or successp + (slime-load-failed-fasl-p))) + (slime-eval-async `(swank:load-file ,faslfile))))) + +(defun slime-show-note-counts (notes secs successp) + (message (concat + (cond (successp "Compilation finished") + (t (slime-add-face 'font-lock-warning-face + "Compilation failed"))) + (if (null notes) ". (No warnings)" ": ") + (mapconcat + (lambda (messages) + (cl-destructuring-bind (sev . notes) messages + (let ((len (length notes))) + (format "%d %s%s" len (slime-severity-label sev) + (if (= len 1) "" "s"))))) + (sort (slime-alistify notes #'slime-note.severity #'eq) + (lambda (x y) (slime-severity< (car y) (car x)))) + " ") + (if secs (format " [%.2f secs]" secs))))) + +(defun slime-highlight-notes (notes) + "Highlight compiler notes, warnings, and errors in the buffer." + (interactive (list (slime-compiler-notes))) + (with-temp-message "Highlighting notes..." + (save-excursion + (save-restriction + (widen) ; highlight notes on the whole buffer + (slime-remove-old-overlays) + (mapc #'slime-overlay-note (slime-merge-notes-for-display notes)))))) + +(defvar slime-note-overlays '() + "List of overlays created by `slime-make-note-overlay'") + +(defun slime-remove-old-overlays () + "Delete the existing note overlays." + (mapc #'delete-overlay slime-note-overlays) + (setq slime-note-overlays '())) + +(defun slime-filter-buffers (predicate) + "Return a list of where PREDICATE returns true. +PREDICATE is executed in the buffer to test." + (cl-remove-if-not (lambda (%buffer) + (with-current-buffer %buffer + (funcall predicate))) + (buffer-list))) + +;;;;; Recompilation. + +;; FIXME: This whole idea is questionable since it depends so +;; crucially on precise source-locs. + +(defun slime-recompile-location (location) + (save-excursion + (slime-goto-source-location location) + (slime-compile-defun))) + +(defun slime-recompile-locations (locations cont) + (slime-eval-async + `(swank:compile-multiple-strings-for-emacs + ',(cl-loop for loc in locations collect + (save-excursion + (slime-goto-source-location loc) + (cl-destructuring-bind (start end) + (slime-region-for-defun-at-point) + (list (buffer-substring-no-properties start end) + (buffer-name) + (slime-current-package) + start + (if (buffer-file-name) + (slime-to-lisp-filename (buffer-file-name)) + nil))))) + ',slime-compilation-policy) + cont)) + + +;;;;; Merging together compiler notes in the same location. + +(defun slime-merge-notes-for-display (notes) + "Merge together notes that refer to the same location. +This operation is \"lossy\" in the broad sense but not for display purposes." + (mapcar #'slime-merge-notes + (slime-group-similar 'slime-notes-in-same-location-p notes))) + +(defun slime-merge-notes (notes) + "Merge NOTES together. Keep the highest severity, concatenate the messages." + (let* ((new-severity (cl-reduce #'slime-most-severe notes + :key #'slime-note.severity)) + (new-message (mapconcat #'slime-note.message notes "\n"))) + (let ((new-note (cl-copy-list (car notes)))) + (setf (cl-getf new-note :message) new-message) + (setf (cl-getf new-note :severity) new-severity) + new-note))) + +(defun slime-notes-in-same-location-p (a b) + (equal (slime-note.location a) (slime-note.location b))) + + +;;;;; Compiler notes list + +(defun slime-one-line-ify (string) + "Return a single-line version of STRING. +Each newlines and following indentation is replaced by a single space." + (with-temp-buffer + (insert string) + (goto-char (point-min)) + (while (re-search-forward "\n[\n \t]*" nil t) + (replace-match " ")) + (buffer-string))) + +(defun slime-xrefs-for-notes (notes) + (let ((xrefs)) + (dolist (note notes) + (let* ((location (cl-getf note :location)) + (fn (cadr (assq :file (cdr location)))) + (file (assoc fn xrefs)) + (node + (list (format "%s: %s" + (cl-getf note :severity) + (slime-one-line-ify (cl-getf note :message))) + location))) + (when fn + (if file + (push node (cdr file)) + (setf xrefs (cl-acons fn (list node) xrefs)))))) + xrefs)) + +(defun slime-maybe-show-xrefs-for-notes (notes) + "Show the compiler notes NOTES if they come from more than one file." + (let ((xrefs (slime-xrefs-for-notes notes))) + (when (slime-length> xrefs 1) ; >1 file + (slime-show-xrefs + xrefs 'definition "Compiler notes" (slime-current-package))))) + +(defun slime-note-has-location-p (note) + (not (eq ':error (car (slime-note.location note))))) + +(defun slime-redefinition-note-p (note) + (eq (slime-note.severity note) :redefinition)) + +(defun slime-create-compilation-log (notes) + "Create a buffer for `next-error' to use." + (with-current-buffer (get-buffer-create (slime-buffer-name :compilation)) + (let ((inhibit-read-only t)) + (erase-buffer)) + (slime-insert-compilation-log notes) + (compilation-mode))) + +(defun slime-maybe-show-compilation-log (notes) + "Display the log on failed compilations or if NOTES is non-nil." + (slime-create-compilation-log notes) + (with-struct (slime-compilation-result. notes duration successp) + slime-last-compilation-result + (unless successp + (with-current-buffer (slime-buffer-name :compilation) + (let ((inhibit-read-only t)) + (goto-char (point-max)) + (insert "Compilation " (if successp "succeeded." "failed.")) + (goto-char (point-min)) + (display-buffer (current-buffer))))))) + +(defun slime-show-compilation-log (notes) + "Create and display the compilation log buffer." + (interactive (list (slime-compiler-notes))) + (slime-with-popup-buffer ((slime-buffer-name :compilation) + :mode 'compilation-mode) + (slime-insert-compilation-log notes))) + +(defun slime-insert-compilation-log (notes) + "Insert NOTES in format suitable for `compilation-mode'." + (cl-destructuring-bind (grouped-notes canonicalized-locs-table) + (slime-group-and-sort-notes notes) + (with-temp-message "Preparing compilation log..." + (let ((inhibit-read-only t) + (inhibit-modification-hooks t)) ; inefficient font-lock-hook + (insert (format "cd %s\n%d compiler notes:\n\n" + default-directory (length notes))) + (dolist (notes grouped-notes) + (let ((loc (gethash (cl-first notes) canonicalized-locs-table)) + (start (point))) + (insert (slime-canonicalized-location-to-string loc) ":") + (slime-insert-note-group notes) + (insert "\n") + (slime-make-note-overlay (cl-first notes) start (1- (point)))))) + (set (make-local-variable 'compilation-skip-threshold) 0) + (setq next-error-last-buffer (current-buffer))))) + +(defun slime-insert-note-group (notes) + "Insert a group of compiler messages." + (insert "\n") + (dolist (note notes) + (insert " " (slime-severity-label (slime-note.severity note)) ": ") + (let ((start (point))) + (insert (slime-note.message note)) + (let ((ctx (slime-note.source-context note))) + (if ctx (insert "\n" ctx))) + (slime-indent-block start 4)) + (insert "\n"))) + +(defun slime-indent-block (start column) + "If the region back to START isn't a one-liner indent it." + (when (< start (line-beginning-position)) + (save-excursion + (goto-char start) + (insert "\n")) + (slime-indent-rigidly start (point) column))) + +(defun slime-canonicalized-location (location) + "Return a list (FILE LINE COLUMN) for slime-location LOCATION. +This is quite an expensive operation so use carefully." + (save-excursion + (slime-goto-location-buffer (slime-location.buffer location)) + (save-excursion + (slime-goto-source-location location) + (list (or (buffer-file-name) (buffer-name)) + (save-restriction + (widen) + (line-number-at-pos)) + (1+ (current-column)))))) + +(defun slime-canonicalized-location-to-string (loc) + (if loc + (cl-destructuring-bind (filename line col) loc + (format "%s:%d:%d" + (cond ((not filename) "") + ((let ((rel (file-relative-name filename))) + (if (< (length rel) (length filename)) + rel))) + (t filename)) + line col)) + (format "Unknown location"))) + +(defun slime-goto-note-in-compilation-log (note) + "Find `note' in the compilation log and display it." + (with-current-buffer (get-buffer (slime-buffer-name :compilation)) + (let ((pos + (save-excursion + (goto-char (point-min)) + (cl-loop for overlay = (slime-find-next-note) + while overlay + for other-note = (overlay-get overlay 'slime-note) + when (slime-notes-in-same-location-p note other-note) + return (overlay-start overlay))))) + (when pos + (slime--display-position pos nil 0))))) + +(defun slime-group-and-sort-notes (notes) + "First sort, then group NOTES according to their canonicalized locs." + (let ((locs (make-hash-table :test #'eq))) + (mapc (lambda (note) + (let ((loc (slime-note.location note))) + (when (slime-location-p loc) + (puthash note (slime-canonicalized-location loc) locs)))) + notes) + (list (slime-group-similar + (lambda (n1 n2) + (equal (gethash n1 locs nil) (gethash n2 locs t))) + (let* ((bottom most-negative-fixnum) + (+default+ (list "" bottom bottom))) + (sort notes + (lambda (n1 n2) + (cl-destructuring-bind ((filename1 line1 col1) + (filename2 line2 col2)) + (list (gethash n1 locs +default+) + (gethash n2 locs +default+)) + (cond ((string-lessp filename1 filename2) t) + ((string-lessp filename2 filename1) nil) + ((< line1 line2) t) + ((> line1 line2) nil) + (t (< col1 col2)))))))) + locs))) + +(defun slime-note.severity (note) + (plist-get note :severity)) + +(defun slime-note.message (note) + (plist-get note :message)) + +(defun slime-note.source-context (note) + (plist-get note :source-context)) + +(defun slime-note.location (note) + (plist-get note :location)) + +(defun slime-severity-label (severity) + (cl-subseq (symbol-name severity) 1)) + + +;;;;; Adding a single compiler note + +(defun slime-overlay-note (note) + "Add a compiler note to the buffer as an overlay. +If an appropriate overlay for a compiler note in the same location +already exists then the new information is merged into it. Otherwise a +new overlay is created." + (cl-multiple-value-bind (start end) (slime-choose-overlay-region note) + (when start + (goto-char start) + (let ((severity (plist-get note :severity)) + (message (plist-get note :message)) + (overlay (slime-note-at-point))) + (if overlay + (slime-merge-note-into-overlay overlay severity message) + (slime-create-note-overlay note start end severity message)))))) + +(defun slime-make-note-overlay (note start end) + (let ((overlay (make-overlay start end))) + (overlay-put overlay 'slime-note note) + (push overlay slime-note-overlays) + overlay)) + +(defun slime-create-note-overlay (note start end severity message) + "Create an overlay representing a compiler note. +The overlay has several properties: + FACE - to underline the relevant text. + SEVERITY - for future reference :NOTE, :STYLE-WARNING, :WARNING, or :ERROR. + MOUSE-FACE - highlight the note when the mouse passes over. + HELP-ECHO - a string describing the note, both for future reference + and for display as a tooltip (due to the special + property name)." + (let ((overlay (slime-make-note-overlay note start end))) + (cl-macrolet ((putp (name value) `(overlay-put overlay ,name ,value))) + (putp 'face (slime-severity-face severity)) + (putp 'severity severity) + (putp 'mouse-face 'highlight) + (putp 'help-echo message) + overlay))) + +;; XXX Obsolete due to `slime-merge-notes-for-display' doing the +;; work already -- unless we decide to put several sets of notes on a +;; buffer without clearing in between, which only this handles. +(defun slime-merge-note-into-overlay (overlay severity message) + "Merge another compiler note into an existing overlay. +The help text describes both notes, and the highest of the severities +is kept." + (cl-macrolet ((putp (name value) `(overlay-put overlay ,name ,value)) + (getp (name) `(overlay-get overlay ,name))) + (putp 'severity (slime-most-severe severity (getp 'severity))) + (putp 'face (slime-severity-face (getp 'severity))) + (putp 'help-echo (concat (getp 'help-echo) "\n" message)))) + +(defun slime-choose-overlay-region (note) + "Choose the start and end points for an overlay over NOTE. +If the location's sexp is a list spanning multiple lines, then the +region around the first element is used. +Return nil if there's no useful source location." + (let ((location (slime-note.location note))) + (when location + (slime-dcase location + ((:error _)) ; do nothing + ((:location file pos _hints) + (cond ((eq (car file) ':source-form) nil) + ((eq (slime-note.severity note) :read-error) + (slime-choose-overlay-for-read-error location)) + ((equal pos '(:eof)) + (cl-values (1- (point-max)) (point-max))) + (t + (slime-choose-overlay-for-sexp location)))))))) + +(defun slime-choose-overlay-for-read-error (location) + (let ((pos (slime-location-offset location))) + (save-excursion + (goto-char pos) + (cond ((slime-symbol-at-point) + ;; package not found, &c. + (cl-values (slime-symbol-start-pos) (slime-symbol-end-pos))) + (t + (cl-values pos (1+ pos))))))) + +(defun slime-choose-overlay-for-sexp (location) + (slime-goto-source-location location) + (skip-chars-forward "'#`") + (let ((start (point))) + (ignore-errors (slime-forward-sexp)) + (if (slime-same-line-p start (point)) + (cl-values start (point)) + (cl-values (1+ start) + (progn (goto-char (1+ start)) + (ignore-errors (forward-sexp 1)) + (point)))))) + +(defun slime-same-line-p (pos1 pos2) + "Return t if buffer positions POS1 and POS2 are on the same line." + (save-excursion (goto-char (min pos1 pos2)) + (<= (max pos1 pos2) (line-end-position)))) + +(defvar slime-severity-face-plist + '(:error slime-error-face + :read-error slime-error-face + :warning slime-warning-face + :redefinition slime-style-warning-face + :style-warning slime-style-warning-face + :note slime-note-face)) + +(defun slime-severity-face (severity) + "Return the name of the font-lock face representing SEVERITY." + (or (plist-get slime-severity-face-plist severity) + (error "No face for: %S" severity))) + +(defvar slime-severity-order + '(:note :style-warning :redefinition :warning :error :read-error)) + +(defun slime-severity< (sev1 sev2) + "Return true if SEV1 is less severe than SEV2." + (< (cl-position sev1 slime-severity-order) + (cl-position sev2 slime-severity-order))) + +(defun slime-most-severe (sev1 sev2) + "Return the most servere of two conditions." + (if (slime-severity< sev1 sev2) sev2 sev1)) + +;; XXX: unused function +(defun slime-visit-source-path (source-path) + "Visit a full source path including the top-level form." + (goto-char (point-min)) + (slime-forward-source-path source-path)) + +(defun slime-forward-positioned-source-path (source-path) + "Move forward through a sourcepath from a fixed position. +The point is assumed to already be at the outermost sexp, making the +first element of the source-path redundant." + (ignore-errors + (slime-forward-sexp) + (beginning-of-defun)) + (let ((source-path (cdr source-path))) + (when source-path + (down-list 1) + (slime-forward-source-path source-path)))) + +(defun slime-forward-source-path (source-path) + (let ((origin (point))) + (condition-case nil + (progn + (cl-loop for (count . more) on source-path + do (progn + (slime-forward-sexp count) + (when more (down-list 1)))) + ;; Align at beginning + (slime-forward-sexp) + (beginning-of-sexp)) + (error (goto-char origin))))) + + +;; FIXME: really fix this mess +;; FIXME: the check shouln't be done here anyway but by M-. itself. + +(defun slime-filesystem-toplevel-directory () + ;; Windows doesn't have a true toplevel root directory, and all + ;; filenames look like "c:/foo/bar/quux.baz" from an Emacs + ;; perspective anyway. + (if (memq system-type '(ms-dos windows-nt)) + "" + (file-name-as-directory "/"))) + +(defun slime-file-name-merge-source-root (target-filename buffer-filename) + "Returns a filename where the source root directory of TARGET-FILENAME +is replaced with the source root directory of BUFFER-FILENAME. + +If no common source root could be determined, return NIL. + +E.g. (slime-file-name-merge-source-root + \"/usr/local/src/joe/upstream/sbcl/code/late-extensions.lisp\" + \"/usr/local/src/joe/hacked/sbcl/compiler/deftype.lisp\") + + ==> \"/usr/local/src/joe/hacked/sbcl/code/late-extensions.lisp\" +" + (let ((target-dirs (split-string (file-name-directory target-filename) + "/" t)) + (buffer-dirs (split-string (file-name-directory buffer-filename) + "/" t))) + ;; Starting from the end, we look if one of the TARGET-DIRS exists + ;; in BUFFER-FILENAME---if so, it and everything left from that dirname + ;; is considered to be the source root directory of BUFFER-FILENAME. + (cl-loop with target-suffix-dirs = nil + with buffer-dirs* = (reverse buffer-dirs) + with target-dirs* = (reverse target-dirs) + for target-dir in target-dirs* + do (let ((concat-dirs (lambda (dirs) + (apply #'concat + (mapcar #'file-name-as-directory + dirs)))) + (pos (cl-position target-dir buffer-dirs* + :test #'equal))) + (if (not pos) ; TARGET-DIR not in BUFFER-FILENAME? + (push target-dir target-suffix-dirs) + (let* ((target-suffix + ; PUSH reversed for us! + (funcall concat-dirs target-suffix-dirs)) + (buffer-root + (funcall concat-dirs + (reverse (nthcdr pos buffer-dirs*))))) + (cl-return (concat (slime-filesystem-toplevel-directory) + buffer-root + target-suffix + (file-name-nondirectory + target-filename))))))))) + +(defun slime-highlight-differences-in-dirname (base-dirname contrast-dirname) + "Returns a copy of BASE-DIRNAME where all differences between +BASE-DIRNAME and CONTRAST-DIRNAME are propertized with a +highlighting face." + (setq base-dirname (file-name-as-directory base-dirname)) + (setq contrast-dirname (file-name-as-directory contrast-dirname)) + (let ((base-dirs (split-string base-dirname "/" t)) + (contrast-dirs (split-string contrast-dirname "/" t))) + (with-temp-buffer + (cl-loop initially (insert (slime-filesystem-toplevel-directory)) + for base-dir in base-dirs do + (let ((pos (cl-position base-dir contrast-dirs :test #'equal))) + (cond ((not pos) + (slime-insert-propertized '(face highlight) base-dir) + (insert "/")) + (t + (insert (file-name-as-directory base-dir)) + (setq contrast-dirs + (nthcdr (1+ pos) contrast-dirs)))))) + (buffer-substring (point-min) (point-max))))) + +(defvar slime-warn-when-possibly-tricked-by-M-. t + "When working on multiple source trees simultaneously, the way +`slime-edit-definition' (M-.) works can sometimes be confusing: + +`M-.' visits locations that are present in the current Lisp image, +which works perfectly well as long as the image reflects the source +tree that one is currently looking at. + +In the other case, however, one can easily end up visiting a file +in a different source root directory (cl-the one corresponding to +the Lisp image), and is thus easily tricked to modify the wrong +source files---which can lead to quite some stressfull cursing. + +If this variable is T, a warning message is issued to raise the +user's attention whenever `M-.' is about opening a file in a +different source root that also exists in the source root +directory of the user's current buffer. + +There's no guarantee that all possible cases are covered, but +if you encounter such a warning, it's a strong indication that +you should check twice before modifying.") + +(defun slime-maybe-warn-for-different-source-root (target-filename + buffer-filename) + (let ((guessed-target (slime-file-name-merge-source-root target-filename + buffer-filename))) + (when (and guessed-target + (not (equal guessed-target target-filename)) + (file-exists-p guessed-target)) + (slime-message "Attention: This is `%s'." + (concat (slime-highlight-differences-in-dirname + (file-name-directory target-filename) + (file-name-directory guessed-target)) + (file-name-nondirectory target-filename)))))) + +(defun slime-check-location-filename-sanity (filename) + (when slime-warn-when-possibly-tricked-by-M-. + (cl-macrolet ((truename-safe (file) `(and ,file (file-truename ,file)))) + (let ((target-filename (truename-safe filename)) + (buffer-filename (truename-safe (buffer-file-name)))) + (when (and target-filename + buffer-filename) + (slime-maybe-warn-for-different-source-root + target-filename buffer-filename)))))) + +(defun slime-check-location-buffer-name-sanity (buffer-name) + (slime-check-location-filename-sanity + (buffer-file-name (get-buffer buffer-name)))) + + + +(defun slime-goto-location-buffer (buffer) + (slime-dcase buffer + ((:file filename) + (let ((filename (slime-from-lisp-filename filename))) + (slime-check-location-filename-sanity filename) + (set-buffer (or (get-file-buffer filename) + (let ((find-file-suppress-same-file-warnings t)) + (find-file-noselect filename)))))) + ((:buffer buffer-name) + (slime-check-location-buffer-name-sanity buffer-name) + (set-buffer buffer-name)) + ((:buffer-and-file buffer filename) + (slime-goto-location-buffer + (if (get-buffer buffer) + (list :buffer buffer) + (list :file filename)))) + ((:source-form string) + (set-buffer (get-buffer-create (slime-buffer-name :source))) + (erase-buffer) + (lisp-mode) + (insert string) + (goto-char (point-min))) + ((:zip file entry) + (require 'arc-mode) + (set-buffer (find-file-noselect file t)) + (goto-char (point-min)) + (re-search-forward (concat " " entry "$")) + (let ((buffer (save-window-excursion + (archive-extract) + (current-buffer)))) + (set-buffer buffer) + (goto-char (point-min)))))) + +(defun slime-goto-location-position (position) + (slime-dcase position + ((:position pos) + (goto-char 1) + (forward-char (- (1- pos) (slime-eol-conversion-fixup (1- pos))))) + ((:offset start offset) + (goto-char start) + (forward-char offset)) + ((:line start &optional column) + (goto-char (point-min)) + (beginning-of-line start) + (cond (column (move-to-column column)) + (t (skip-chars-forward " \t")))) + ((:function-name name) + (let ((case-fold-search t) + (name (regexp-quote name))) + (goto-char (point-min)) + (when (or + (re-search-forward + (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +(*%s\\S_" + (regexp-quote name)) nil t) + (re-search-forward + (format "[( \t]%s\\>\\(\\s \\|$\\)" name) nil t)) + (goto-char (match-beginning 0))))) + ((:method name specializers &rest qualifiers) + (slime-search-method-location name specializers qualifiers)) + ((:source-path source-path start-position) + (cond (start-position + (goto-char start-position) + (slime-forward-positioned-source-path source-path)) + (t + (slime-forward-source-path source-path)))) + ((:eof) + (goto-char (point-max))))) + +(defun slime-eol-conversion-fixup (n) + ;; Return the number of \r\n eol markers that we need to cross when + ;; moving N chars forward. N is the number of chars but \r\n are + ;; counted as 2 separate chars. + (cl-case (coding-system-eol-type buffer-file-coding-system) + ((1) + (save-excursion + (cl-do ((pos (+ (point) n)) + (count 0 (1+ count))) + ((>= (point) pos) (1- count)) + (forward-line) + (cl-decf pos)))) + (t 0))) + +(defun slime-search-method-location (name specializers qualifiers) + ;; Look for a sequence of words (def<something> method name + ;; qualifers specializers don't look for "T" since it isn't requires + ;; (arg without t) as class is taken as such. + (let* ((case-fold-search t) + (name (regexp-quote name)) + (qualifiers (mapconcat (lambda (el) (concat ".+?\\<" el "\\>")) + qualifiers "")) + (specializers (mapconcat + (lambda (el) + (if (eql (aref el 0) ?\() + (let ((spec (read el))) + (if (eq (car spec) 'EQL) + (concat + ".*?\\n\\{0,1\\}.*?(EQL.*?'\\{0,1\\}" + (format "%s" (cl-second spec)) ")") + (error "don't understand specializer: %s,%s" + el (car spec)))) + (concat ".+?\n\\{0,1\\}.+?\\<" el "\\>"))) + (remove "T" specializers) "")) + (regexp (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +%s\\s +%s%s" name + qualifiers specializers))) + (or (and (re-search-forward regexp nil t) + (goto-char (match-beginning 0))) + ;; (slime-goto-location-position `(:function-name ,name)) + ))) + +(defun slime-search-call-site (fname) + "Move to the place where FNAME called. +Don't move if there are multiple or no calls in the current defun." + (save-restriction + (narrow-to-defun) + (let ((start (point)) + (regexp (concat "(" fname "[)\n \t]")) + (case-fold-search t)) + (cond ((and (re-search-forward regexp nil t) + (not (re-search-forward regexp nil t))) + (goto-char (match-beginning 0))) + (t (goto-char start)))))) + +(defun slime-search-edit-path (edit-path) + "Move to EDIT-PATH starting at the current toplevel form." + (when edit-path + (unless (and (= (current-column) 0) + (looking-at "(")) + (beginning-of-defun)) + (slime-forward-source-path edit-path))) + +(defun slime-goto-source-location (location &optional noerror) + "Move to the source location LOCATION. Several kinds of locations +are supported: + +<location> ::= (:location <buffer> <position> <hints>) + | (:error <message>) + +<buffer> ::= (:file <filename>) + | (:buffer <buffername>) + | (:buffer-and-file <buffername> <filename>) + | (:source-form <string>) + | (:zip <file> <entry>) + +<position> ::= (:position <fixnum>) ; 1 based (for files) + | (:offset <start> <offset>) ; start+offset (for C-c C-c) + | (:line <line> [<column>]) + | (:function-name <string>) + | (:source-path <list> <start-position>) + | (:method <name string> <specializers> . <qualifiers>)" + (slime-dcase location + ((:location buffer _position _hints) + (slime-goto-location-buffer buffer) + (let ((pos (slime-location-offset location))) + (cond ((and (<= (point-min) pos) (<= pos (point-max)))) + (widen-automatically (widen)) + (t + (error "Location is outside accessible part of buffer"))) + (goto-char pos))) + ((:error message) + (if noerror + (slime-message "%s" message) + (error "%s" message))))) + +(defun slime-location-offset (location) + "Return the position, as character number, of LOCATION." + (save-restriction + (widen) + (condition-case nil + (slime-goto-location-position + (slime-location.position location)) + (error (goto-char 0))) + (cl-destructuring-bind (&key snippet edit-path call-site align) + (slime-location.hints location) + (when snippet (slime-isearch snippet)) + (when edit-path (slime-search-edit-path edit-path)) + (when call-site (slime-search-call-site call-site)) + (when align + (slime-forward-sexp) + (beginning-of-sexp))) + (point))) + + +;;;;; Incremental search +;; +;; Search for the longest match of a string in either direction. +;; +;; This is for locating text that is expected to be near the point and +;; may have been modified (but hopefully not near the beginning!) + +(defun slime-isearch (string) + "Find the longest occurence of STRING either backwards of forwards. +If multiple matches exist the choose the one nearest to point." + (goto-char + (let* ((start (point)) + (len1 (slime-isearch-with-function 'search-forward string)) + (pos1 (point))) + (goto-char start) + (let* ((len2 (slime-isearch-with-function 'search-backward string)) + (pos2 (point))) + (cond ((and len1 len2) + ;; Have a match in both directions + (cond ((= len1 len2) + ;; Both are full matches -- choose the nearest. + (if (< (abs (- start pos1)) + (abs (- start pos2))) + pos1 pos2)) + ((> len1 len2) pos1) + ((> len2 len1) pos2))) + (len1 pos1) + (len2 pos2) + (t start)))))) + +(defun slime-isearch-with-function (search-fn string) + "Search for the longest substring of STRING using SEARCH-FN. +SEARCH-FN is either the symbol `search-forward' or `search-backward'." + (unless (string= string "") + (cl-loop for i from 1 to (length string) + while (funcall search-fn (substring string 0 i) nil t) + for match-data = (match-data) + do (cl-case search-fn + (search-forward (goto-char (match-beginning 0))) + (search-backward (goto-char (1+ (match-end 0))))) + finally (cl-return (if (null match-data) + nil + ;; Finish based on the last successful match + (store-match-data match-data) + (goto-char (match-beginning 0)) + (- (match-end 0) (match-beginning 0))))))) + + +;;;;; Visiting and navigating the overlays of compiler notes + +(defun slime-next-note () + "Go to and describe the next compiler note in the buffer." + (interactive) + (let ((here (point)) + (note (slime-find-next-note))) + (if note + (slime-show-note note) + (goto-char here) + (message "No next note.")))) + +(defun slime-previous-note () + "Go to and describe the previous compiler note in the buffer." + (interactive) + (let ((here (point)) + (note (slime-find-previous-note))) + (if note + (slime-show-note note) + (goto-char here) + (message "No previous note.")))) + +(defun slime-goto-first-note (&rest _) + "Go to the first note in the buffer." + (let ((point (point))) + (goto-char (point-min)) + (cond ((slime-find-next-note) + (slime-show-note (slime-note-at-point))) + (t (goto-char point))))) + +(defun slime-remove-notes () + "Remove compiler-note annotations from the current buffer." + (interactive) + (slime-remove-old-overlays)) + +(defun slime-show-note (overlay) + "Present the details of a compiler note to the user." + (slime-temporarily-highlight-note overlay) + (if (get-buffer-window (slime-buffer-name :compilation) t) + (slime-goto-note-in-compilation-log (overlay-get overlay 'slime-note)) + (let ((message (get-char-property (point) 'help-echo))) + (slime-message "%s" (if (zerop (length message)) "\"\"" message))))) + +;; FIXME: could probably use flash region +(defun slime-temporarily-highlight-note (overlay) + "Temporarily highlight a compiler note's overlay. +The highlighting is designed to both make the relevant source more +visible, and to highlight any further notes that are nested inside the +current one. + +The highlighting is automatically undone with a timer." + (run-with-timer 0.2 nil + #'overlay-put overlay 'face (overlay-get overlay 'face)) + (overlay-put overlay 'face 'slime-highlight-face)) + + +;;;;; Overlay lookup operations + +(defun slime-note-at-point () + "Return the overlay for a note starting at point, otherwise NIL." + (cl-find (point) (slime-note-overlays-at-point) + :key 'overlay-start)) + +(defun slime-note-overlay-p (overlay) + "Return true if OVERLAY represents a compiler note." + (overlay-get overlay 'slime-note)) + +(defun slime-note-overlays-at-point () + "Return a list of all note overlays that are under the point." + (cl-remove-if-not 'slime-note-overlay-p (overlays-at (point)))) + +(defun slime-find-next-note () + "Go to the next position with the `slime-note' text property. +Retuns the note overlay if such a position is found, otherwise nil." + (slime-search-property 'slime-note nil #'slime-note-at-point)) + +(defun slime-find-previous-note () + "Go to the next position with the `slime-note' text property. +Retuns the note overlay if such a position is found, otherwise nil." + (slime-search-property 'slime-note t #'slime-note-at-point)) + + +;;;; Arglist Display + +(defun slime-space (n) + "Insert a space and print some relevant information (function arglist). +Designed to be bound to the SPC key. Prefix argument can be used to insert +more than one space." + (interactive "p") + (self-insert-command n) + (slime-echo-arglist)) + +(put 'slime-space 'delete-selection t) ; for delete-section-mode & CUA + +(defun slime-echo-arglist () + (when (slime-background-activities-enabled-p) + (let ((op (slime-operator-before-point))) + (when op + (slime-eval-async `(swank:operator-arglist ,op + ,(slime-current-package)) + (lambda (arglist) + (when arglist + (slime-message "%s" arglist)))))))) + +(defvar slime-operator-before-point-function 'slime-lisp-operator-before-point) + +(defun slime-operator-before-point () + (funcall slime-operator-before-point-function)) + +(defun slime-lisp-operator-before-point () + (ignore-errors + (save-excursion + (backward-up-list 1) + (down-list 1) + (slime-symbol-at-point)))) + +;;;; Completion + +;; FIXME: use this in Emacs 24 +;;(define-obsolete-function-alias slime-complete-symbol completion-at-point) + +(defalias 'slime-complete-symbol #'completion-at-point) +(make-obsolete 'slime-complete-symbol #'completion-at-point "2015-10-17") + +;; This is the function that we add to +;; `completion-at-point-functions'. For backward-compatibilty we look +;; at `slime-complete-symbol-function' first. The indirection through +;; `slime-completion-at-point-functions' is used so that users don't +;; have to set `completion-at-point-functions' in every slime-like +;; buffer. +(defun slime--completion-at-point () + (cond (slime-complete-symbol-function + slime-complete-symbol-function) + (t + (run-hook-with-args-until-success + 'slime-completion-at-point-functions)))) + +(defun slime-setup-completion () + (add-hook 'completion-at-point-functions #'slime--completion-at-point nil t)) + +(defun slime-simple-completion-at-point () + "Complete the symbol at point. +Perform completion similar to `elisp-completion-at-point'." + (let* ((end (point)) + (beg (slime-symbol-start-pos))) + (list beg end (completion-table-dynamic #'slime-simple-completions)))) + +(defun slime-filename-completion () + "If point is at a string starting with \", complete it as filename. +Return nil if point is not at filename." + (when (save-excursion (re-search-backward "\"[^ \t\n]+\\=" + (max (point-min) (- (point) 1000)) + t)) + (let ((comint-completion-addsuffix '("/" . "\""))) + (comint-filename-completion)))) + +;; FIXME: for backward compatibility. Remove it one day +;; together with slime-complete-symbol-function. +(defun slime-simple-complete-symbol () + (let ((completion-at-point-functions '(slime-maybe-complete-as-filename + slime-simple-completion-at-point))) + (completion-at-point))) + +;; NOTE: the original idea was to bind this to TAB but that no longer +;; works as `completion-at-point' sets a transient keymap that +;; overrides TAB. So this is rather useless now. +(defun slime-indent-and-complete-symbol () + "Indent the current line and perform symbol completion. +First indent the line. If indenting doesn't move point, complete +the symbol. If there's no symbol at the point, show the arglist +for the most recently enclosed macro or function." + (interactive) + (let ((pos (point))) + (unless (get-text-property (line-beginning-position) 'slime-repl-prompt) + (lisp-indent-line)) + (when (= pos (point)) + (cond ((save-excursion (re-search-backward "[^() \n\t\r]+\\=" nil t)) + (completion-at-point)) + ((memq (char-before) '(?\t ?\ )) + (slime-echo-arglist)))))) + +(make-obsolete 'slime-indent-and-complete-symbol + "Set tab-always-indent to 'complete." + "2015-10-18") + +(defvar slime-minibuffer-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map minibuffer-local-map) + (define-key map "\t" #'completion-at-point) + (define-key map "\M-\t" #'completion-at-point) + map) + "Minibuffer keymap used for reading CL expressions.") + +(defvar slime-minibuffer-history '() + "History list of expressions read from the minibuffer.") + +(defun slime-minibuffer-setup-hook () + (cons (lexical-let ((package (slime-current-package)) + (connection (slime-connection))) + (lambda () + (setq slime-buffer-package package) + (setq slime-buffer-connection connection) + (set-syntax-table lisp-mode-syntax-table) + (slime-setup-completion))) + minibuffer-setup-hook)) + +(defun slime-read-from-minibuffer (prompt &optional initial-value history) + "Read a string from the minibuffer, prompting with PROMPT. +If INITIAL-VALUE is non-nil, it is inserted into the minibuffer before +reading input. The result is a string (\"\" if no input was given)." + (let ((minibuffer-setup-hook (slime-minibuffer-setup-hook))) + (read-from-minibuffer prompt initial-value slime-minibuffer-map + nil (or history 'slime-minibuffer-history)))) + +(defun slime-bogus-completion-alist (list) + "Make an alist out of list. +The same elements go in the CAR, and nil in the CDR. To support the +apparently very stupid `try-completions' interface, that wants an +alist but ignores CDRs." + (mapcar (lambda (x) (cons x nil)) list)) + +(defun slime-simple-completions (prefix) + (cl-destructuring-bind (completions _partial) + (let ((slime-current-thread t)) + (slime-eval + `(swank:simple-completions ,(substring-no-properties prefix) + ',(slime-current-package)))) + completions)) + + +;;;; Edit definition + +(defun slime-push-definition-stack () + "Add point to find-tag-marker-ring." + (require 'etags) + (ring-insert find-tag-marker-ring (point-marker))) + +(defun slime-pop-find-definition-stack () + "Pop the edit-definition stack and goto the location." + (interactive) + (pop-tag-mark)) + +(cl-defstruct (slime-xref (:conc-name slime-xref.) (:type list)) + dspec location) + +(cl-defstruct (slime-location (:conc-name slime-location.) (:type list) + (:constructor nil) + (:copier nil)) + tag buffer position hints) + +(defun slime-location-p (o) (and (consp o) (eq (car o) :location))) + +(defun slime-xref-has-location-p (xref) + (slime-location-p (slime-xref.location xref))) + +(defun make-slime-buffer-location (buffer-name position &optional hints) + `(:location (:buffer ,buffer-name) (:position ,position) + ,(when hints `(:hints ,hints)))) + +(defun make-slime-file-location (file-name position &optional hints) + `(:location (:file ,file-name) (:position ,position) + ,(when hints `(:hints ,hints)))) + +;;; The hooks are tried in order until one succeeds, otherwise the +;;; default implementation involving `slime-find-definitions-function' +;;; is used. The hooks are called with the same arguments as +;;; `slime-edit-definition'. +(defvar slime-edit-definition-hooks) + +(defun slime-edit-definition (&optional name where) + "Lookup the definition of the name at point. +If there's no name at point, or a prefix argument is given, then the +function name is prompted." + (interactive (list (or (and (not current-prefix-arg) + (slime-symbol-at-point)) + (slime-read-symbol-name "Edit Definition of: ")))) + ;; The hooks might search for a name in a different manner, so don't + ;; ask the user if it's missing before the hooks are run + (or (run-hook-with-args-until-success 'slime-edit-definition-hooks + name where) + (slime-edit-definition-cont (slime-find-definitions name) + name where))) + +(defun slime-edit-definition-cont (xrefs name where) + (cl-destructuring-bind (1loc file-alist) (slime-analyze-xrefs xrefs) + (cond ((null xrefs) + (error "No known definition for: %s (in %s)" + name (slime-current-package))) + (1loc + (slime-push-definition-stack) + (slime-pop-to-location (slime-xref.location (car xrefs)) where)) + ((slime-length= xrefs 1) ; ((:error "...")) + (error "%s" (cadr (slime-xref.location (car xrefs))))) + (t + (slime-push-definition-stack) + (slime-show-xrefs file-alist 'definition name + (slime-current-package)))))) + +(defvar slime-edit-uses-xrefs + '(:calls :macroexpands :binds :references :sets :specializes)) + +;;; FIXME. TODO: Would be nice to group the symbols (in each +;;; type-group) by their home-package. +(defun slime-edit-uses (symbol) + "Lookup all the uses of SYMBOL." + (interactive (list (slime-read-symbol-name "Edit Uses of: "))) + (slime-xrefs slime-edit-uses-xrefs + symbol + (lambda (xrefs type symbol package) + (cond + ((null xrefs) + (message "No xref information found for %s." symbol)) + ((and (slime-length= xrefs 1) ; one group + (slime-length= (cdar xrefs) 1)) ; one ref in group + (cl-destructuring-bind (_ (_ loc)) (cl-first xrefs) + (slime-push-definition-stack) + (slime-pop-to-location loc))) + (t + (slime-push-definition-stack) + (slime-show-xref-buffer xrefs type symbol package)))))) + +(defun slime-analyze-xrefs (xrefs) + "Find common filenames in XREFS. +Return a list (SINGLE-LOCATION FILE-ALIST). +SINGLE-LOCATION is true if all xrefs point to the same location. +FILE-ALIST is an alist of the form ((FILENAME . (XREF ...)) ...)." + (list (and xrefs + (let ((loc (slime-xref.location (car xrefs)))) + (and (slime-location-p loc) + (cl-every (lambda (x) (equal (slime-xref.location x) loc)) + (cdr xrefs))))) + (slime-alistify xrefs #'slime-xref-group #'equal))) + +(defun slime-xref-group (xref) + (cond ((slime-xref-has-location-p xref) + (slime-dcase (slime-location.buffer (slime-xref.location xref)) + ((:file filename) filename) + ((:buffer bufname) + (let ((buffer (get-buffer bufname))) + (if buffer + (format "%S" buffer) ; "#<buffer foo.lisp>" + (format "%s (previously existing buffer)" bufname)))) + ((:buffer-and-file _buffer filename) filename) + ((:source-form _) "(S-Exp)") + ((:zip _zip entry) entry))) + (t + "(No location)"))) + +(defun slime-pop-to-location (location &optional where) + (slime-goto-source-location location) + (cl-ecase where + ((nil) (switch-to-buffer (current-buffer))) + (window (pop-to-buffer (current-buffer) t)) + (frame (let ((pop-up-frames t)) (pop-to-buffer (current-buffer) t))))) + +(defun slime-postprocess-xref (original-xref) + "Process (for normalization purposes) an Xref comming directly +from SWANK before the rest of Slime sees it. In particular, +convert ETAGS based xrefs to actual file+position based +locations." + (if (not (slime-xref-has-location-p original-xref)) + (list original-xref) + (let ((loc (slime-xref.location original-xref))) + (slime-dcase (slime-location.buffer loc) + ((:etags-file tags-file) + (slime-dcase (slime-location.position loc) + ((:tag &rest tags) + (visit-tags-table tags-file) + (mapcar (lambda (xref) + (let ((old-dspec (slime-xref.dspec original-xref)) + (new-dspec (slime-xref.dspec xref))) + (setf (slime-xref.dspec xref) + (format "%s: %s" old-dspec new-dspec)) + xref)) + (cl-mapcan #'slime-etags-definitions tags))))) + (t + (list original-xref)))))) + +(defun slime-postprocess-xrefs (xrefs) + (cl-mapcan #'slime-postprocess-xref xrefs)) + +(defun slime-find-definitions (name) + "Find definitions for NAME." + (slime-postprocess-xrefs (funcall slime-find-definitions-function name))) + +(defun slime-find-definitions-rpc (name) + (slime-eval `(swank:find-definitions-for-emacs ,name))) + +(defun slime-edit-definition-other-window (name) + "Like `slime-edit-definition' but switch to the other window." + (interactive (list (slime-read-symbol-name "Symbol: "))) + (slime-edit-definition name 'window)) + +(defun slime-edit-definition-other-frame (name) + "Like `slime-edit-definition' but switch to the other window." + (interactive (list (slime-read-symbol-name "Symbol: "))) + (slime-edit-definition name 'frame)) + +(defun slime-edit-definition-with-etags (name) + (interactive (list (slime-read-symbol-name "Symbol: "))) + (let ((xrefs (slime-etags-definitions name))) + (cond (xrefs + (message "Using tag file...") + (slime-edit-definition-cont xrefs name nil)) + (t + (error "No known definition for: %s" name))))) + +(defun slime-etags-to-locations (name) + "Search for definitions matching `name' in the currently active +tags table. Return a possibly empty list of slime-locations." + (let ((locs '())) + (save-excursion + (let ((first-time t)) + (while (visit-tags-table-buffer (not first-time)) + (setq first-time nil) + (goto-char (point-min)) + (while (search-forward name nil t) + (beginning-of-line) + (cl-destructuring-bind (hint line &rest pos) (etags-snarf-tag) + (unless (eq hint t) ; hint==t if we are in a filename line + (push `(:location (:file ,(expand-file-name (file-of-tag))) + (:line ,line) + (:snippet ,hint)) + locs)))))) + (nreverse locs)))) + +(defun slime-etags-definitions (name) + "Search definitions matching NAME in the tags file. +The result is a (possibly empty) list of definitions." + (mapcar (lambda (loc) + (make-slime-xref :dspec (cl-second (slime-location.hints loc)) + :location loc)) + (slime-etags-to-locations name))) + +;;;;; first-change-hook + +(defun slime-first-change-hook () + "Notify Lisp that a source file's buffer has been modified." + ;; Be careful not to disturb anything! + ;; In particular if we muck up the match-data then query-replace + ;; breaks. -luke (26/Jul/2004) + (save-excursion + (save-match-data + (when (and (buffer-file-name) + (file-exists-p (buffer-file-name)) + (slime-background-activities-enabled-p)) + (let ((filename (slime-to-lisp-filename (buffer-file-name)))) + (slime-eval-async `(swank:buffer-first-change ,filename))))))) + +(defun slime-setup-first-change-hook () + (add-hook (make-local-variable 'first-change-hook) + 'slime-first-change-hook)) + +(add-hook 'slime-mode-hook 'slime-setup-first-change-hook) + + +;;;; Eval for Lisp + +(defun slime-lisp-readable-p (x) + (or (stringp x) + (memq x '(nil t)) + (integerp x) + (keywordp x) + (and (consp x) + (let ((l x)) + (while (consp l) + (slime-lisp-readable-p (car x)) + (setq l (cdr l))) + (slime-lisp-readable-p l))))) + +(defun slime-eval-for-lisp (thread tag form-string) + (let ((ok nil) + (value nil) + (error nil) + (c (slime-connection))) + (unwind-protect + (condition-case err + (progn + (slime-check-eval-in-emacs-enabled) + (setq value (eval (read form-string))) + (setq ok t)) + ((debug error) + (setq error err))) + (let ((result (cond ((and ok + (not (slime-lisp-readable-p value))) + `(:unreadable ,(slime-prin1-to-string value))) + (ok `(:ok ,value)) + (error `(:error ,(symbol-name (car error)) + . ,(mapcar #'slime-prin1-to-string + (cdr error)))) + (t `(:abort))))) + (slime-dispatch-event `(:emacs-return ,thread ,tag ,result) c))))) + +(defun slime-check-eval-in-emacs-enabled () + "Raise an error if `slime-enable-evaluate-in-emacs' isn't true." + (unless slime-enable-evaluate-in-emacs + (error (concat "slime-eval-in-emacs disabled for security. " + "Set `slime-enable-evaluate-in-emacs' true to enable it.")))) + + +;;;; `ED' + +(defvar slime-ed-frame nil + "The frame used by `slime-ed'.") + +(defcustom slime-ed-use-dedicated-frame t + "*When non-nil, `slime-ed' will create and reuse a dedicated frame." + :type 'boolean + :group 'slime-mode) + +(defun slime-ed (what) + "Edit WHAT. + +WHAT can be: + A filename (string), + A list (:filename FILENAME &key LINE COLUMN POSITION), + A function name (:function-name STRING) + nil. + +This is for use in the implementation of COMMON-LISP:ED." + (when slime-ed-use-dedicated-frame + (unless (and slime-ed-frame (frame-live-p slime-ed-frame)) + (setq slime-ed-frame (make-frame))) + (select-frame slime-ed-frame)) + (when what + (slime-dcase what + ((:filename file &key line column position bytep) + (find-file (slime-from-lisp-filename file)) + (when line (slime-goto-line line)) + (when column (move-to-column column)) + (when position + (goto-char (if bytep + (byte-to-position position) + position)))) + ((:function-name name) + (slime-edit-definition name))))) + +(defun slime-goto-line (line-number) + "Move to line LINE-NUMBER (1-based). +This is similar to `goto-line' but without pushing the mark and +the display stuff that we neither need nor want." + (cl-assert (= (buffer-size) (- (point-max) (point-min))) () + "slime-goto-line in narrowed buffer") + (goto-char (point-min)) + (forward-line (1- line-number))) + +(defun slime-y-or-n-p (thread tag question) + (slime-dispatch-event `(:emacs-return ,thread ,tag ,(y-or-n-p question)))) + +(defun slime-read-from-minibuffer-for-swank (thread tag prompt initial-value) + (let ((answer (condition-case nil + (slime-read-from-minibuffer prompt initial-value) + (quit nil)))) + (slime-dispatch-event `(:emacs-return ,thread ,tag ,answer)))) + +;;;; Interactive evaluation. + +(defun slime-interactive-eval (string) + "Read and evaluate STRING and print value in minibuffer. + +Note: If a prefix argument is in effect then the result will be +inserted in the current buffer." + (interactive (list (slime-read-from-minibuffer "Slime Eval: "))) + (cl-case current-prefix-arg + ((nil) + (slime-eval-with-transcript `(swank:interactive-eval ,string))) + ((-) + (slime-eval-save string)) + (t + (slime-eval-print string)))) + +(defvar slime-transcript-start-hook nil + "Hook run before start an evalution.") +(defvar slime-transcript-stop-hook nil + "Hook run after finishing a evalution.") + +(defun slime-display-eval-result (value) + (slime-message "%s" value)) + +(defun slime-eval-with-transcript (form) + "Eval FORM in Lisp. Display output, if any." + (run-hooks 'slime-transcript-start-hook) + (slime-rex () (form) + ((:ok value) + (run-hooks 'slime-transcript-stop-hook) + (slime-display-eval-result value)) + ((:abort condition) + (run-hooks 'slime-transcript-stop-hook) + (message "Evaluation aborted on %s." condition)))) + +(defun slime-eval-print (string) + "Eval STRING in Lisp; insert any output and the result at point." + (slime-eval-async `(swank:eval-and-grab-output ,string) + (lambda (result) + (cl-destructuring-bind (output value) result + (push-mark) + (insert output value))))) + +(defun slime-eval-save (string) + "Evaluate STRING in Lisp and save the result in the kill ring." + (slime-eval-async `(swank:eval-and-grab-output ,string) + (lambda (result) + (cl-destructuring-bind (output value) result + (let ((string (concat output value))) + (kill-new string) + (message "Evaluation finished; pushed result to kill ring.")))))) + +(defun slime-eval-describe (form) + "Evaluate FORM in Lisp and display the result in a new buffer." + (slime-eval-async form (slime-rcurry #'slime-show-description + (slime-current-package)))) + +(defvar slime-description-autofocus nil + "If non-nil select description windows on display.") + +(defun slime-show-description (string package) + ;; So we can have one description buffer open per connection. Useful + ;; for comparing the output of DISASSEMBLE across implementations. + ;; FIXME: could easily be achieved with M-x rename-buffer + (let ((bufname (slime-buffer-name :description))) + (slime-with-popup-buffer (bufname :package package + :connection t + :select slime-description-autofocus) + (princ string) + (goto-char (point-min))))) + +(defun slime-last-expression () + (buffer-substring-no-properties + (save-excursion (backward-sexp) (point)) + (point))) + +(defun slime-eval-last-expression () + "Evaluate the expression preceding point." + (interactive) + (slime-interactive-eval (slime-last-expression))) + +(defun slime-eval-defun () + "Evaluate the current toplevel form. +Use `slime-re-evaluate-defvar' if the from starts with '(defvar'" + (interactive) + (let ((form (slime-defun-at-point))) + (cond ((string-match "^(defvar " form) + (slime-re-evaluate-defvar form)) + (t + (slime-interactive-eval form))))) + +(defun slime-eval-region (start end) + "Evaluate region." + (interactive "r") + (slime-eval-with-transcript + `(swank:interactive-eval-region + ,(buffer-substring-no-properties start end)))) + +(defun slime-pprint-eval-region (start end) + "Evaluate region; pprint the value in a buffer." + (interactive "r") + (slime-eval-describe + `(swank:pprint-eval + ,(buffer-substring-no-properties start end)))) + +(defun slime-eval-buffer () + "Evaluate the current buffer. +The value is printed in the echo area." + (interactive) + (slime-eval-region (point-min) (point-max))) + +(defun slime-re-evaluate-defvar (form) + "Force the re-evaluaton of the defvar form before point. + +First make the variable unbound, then evaluate the entire form." + (interactive (list (slime-last-expression))) + (slime-eval-with-transcript `(swank:re-evaluate-defvar ,form))) + +(defun slime-pprint-eval-last-expression () + "Evaluate the form before point; pprint the value in a buffer." + (interactive) + (slime-eval-describe `(swank:pprint-eval ,(slime-last-expression)))) + +(defun slime-eval-print-last-expression (string) + "Evaluate sexp before point; print value into the current buffer" + (interactive (list (slime-last-expression))) + (insert "\n") + (slime-eval-print string)) + +;;;; Edit Lisp value +;;; +(defun slime-edit-value (form-string) + "\\<slime-edit-value-mode-map>\ +Edit the value of a setf'able form in a new buffer. +The value is inserted into a temporary buffer for editing and then set +in Lisp when committed with \\[slime-edit-value-commit]." + (interactive + (list (slime-read-from-minibuffer "Edit value (evaluated): " + (slime-sexp-at-point)))) + (slime-eval-async `(swank:value-for-editing ,form-string) + (lexical-let ((form-string form-string) + (package (slime-current-package))) + (lambda (result) + (slime-edit-value-callback form-string result + package))))) + +(make-variable-buffer-local + (defvar slime-edit-form-string nil + "The form being edited by `slime-edit-value'.")) + +(define-minor-mode slime-edit-value-mode + "Mode for editing a Lisp value." + nil + " Edit-Value" + '(("\C-c\C-c" . slime-edit-value-commit))) + +(defun slime-edit-value-callback (form-string current-value package) + (let* ((name (generate-new-buffer-name (format "*Edit %s*" form-string))) + (buffer (slime-with-popup-buffer (name :package package + :connection t + :select t + :mode 'lisp-mode) + (slime-popup-buffer-mode -1) ; don't want binding of 'q' + (slime-mode 1) + (slime-edit-value-mode 1) + (setq slime-edit-form-string form-string) + (insert current-value) + (current-buffer)))) + (with-current-buffer buffer + (setq buffer-read-only nil) + (message "Type C-c C-c when done")))) + +(defun slime-edit-value-commit () + "Commit the edited value to the Lisp image. +\\(See `slime-edit-value'.)" + (interactive) + (if (null slime-edit-form-string) + (error "Not editing a value.") + (let ((value (buffer-substring-no-properties (point-min) (point-max)))) + (lexical-let ((buffer (current-buffer))) + (slime-eval-async `(swank:commit-edited-value ,slime-edit-form-string + ,value) + (lambda (_) + (with-current-buffer buffer + (quit-window t)))))))) + +;;;; Tracing + +(defun slime-untrace-all () + "Untrace all functions." + (interactive) + (slime-eval `(swank:untrace-all))) + +(defun slime-toggle-trace-fdefinition (spec) + "Toggle trace." + (interactive (list (slime-read-from-minibuffer + "(Un)trace: " (slime-symbol-at-point)))) + (message "%s" (slime-eval `(swank:swank-toggle-trace ,spec)))) + + + +(defun slime-disassemble-symbol (symbol-name) + "Display the disassembly for SYMBOL-NAME." + (interactive (list (slime-read-symbol-name "Disassemble: "))) + (slime-eval-describe `(swank:disassemble-form ,(concat "'" symbol-name)))) + +(defun slime-undefine-function (symbol-name) + "Unbind the function slot of SYMBOL-NAME." + (interactive (list (slime-read-symbol-name "fmakunbound: " t))) + (slime-eval-async `(swank:undefine-function ,symbol-name) + (lambda (result) (message "%s" result)))) + +(defun slime-unintern-symbol (symbol-name package) + "Unintern the symbol given with SYMBOL-NAME PACKAGE." + (interactive (list (slime-read-symbol-name "Unintern symbol: " t) + (slime-read-package-name "from package: " + (slime-current-package)))) + (slime-eval-async `(swank:unintern-symbol ,symbol-name ,package) + (lambda (result) (message "%s" result)))) + +(defun slime-delete-package (package-name) + "Delete the package with name PACKAGE-NAME." + (interactive (list (slime-read-package-name "Delete package: " + (slime-current-package)))) + (slime-eval-async `(cl:delete-package + (swank::guess-package ,package-name)))) + +(defun slime-load-file (filename) + "Load the Lisp file FILENAME." + (interactive (list + (read-file-name "Load file: " nil nil + nil (if (buffer-file-name) + (file-name-nondirectory + (buffer-file-name)))))) + (let ((lisp-filename (slime-to-lisp-filename (expand-file-name filename)))) + (slime-eval-with-transcript `(swank:load-file ,lisp-filename)))) + +(defvar slime-change-directory-hooks nil + "Hook run by `slime-change-directory'. +The functions are called with the new (absolute) directory.") + +(defun slime-change-directory (directory) + "Make DIRECTORY become Lisp's current directory. +Return whatever swank:set-default-directory returns." + (let ((dir (expand-file-name directory))) + (prog1 (slime-eval `(swank:set-default-directory + ,(slime-to-lisp-filename dir))) + (slime-with-connection-buffer nil (cd-absolute dir)) + (run-hook-with-args 'slime-change-directory-hooks dir)))) + +(defun slime-cd (directory) + "Make DIRECTORY become Lisp's current directory. +Return whatever swank:set-default-directory returns." + (interactive (list (read-directory-name "Directory: " nil nil t))) + (message "default-directory: %s" (slime-change-directory directory))) + +(defun slime-pwd () + "Show Lisp's default directory." + (interactive) + (message "Directory %s" (slime-eval `(swank:default-directory)))) + + +;;;; Profiling + +(defun slime-toggle-profile-fdefinition (fname-string) + "Toggle profiling for FNAME-STRING." + (interactive (list (slime-read-from-minibuffer + "(Un)Profile: " + (slime-symbol-at-point)))) + (slime-eval-async `(swank:toggle-profile-fdefinition ,fname-string) + (lambda (r) (message "%s" r)))) + +(defun slime-unprofile-all () + "Unprofile all functions." + (interactive) + (slime-eval-async '(swank:unprofile-all) + (lambda (r) (message "%s" r)))) + +(defun slime-profile-report () + "Print profile report." + (interactive) + (slime-eval-with-transcript '(swank:profile-report))) + +(defun slime-profile-reset () + "Reset profile counters." + (interactive) + (slime-eval-async (slime-eval `(swank:profile-reset)) + (lambda (r) (message "%s" r)))) + +(defun slime-profiled-functions () + "Return list of names of currently profiled functions." + (interactive) + (slime-eval-async `(swank:profiled-functions) + (lambda (r) (message "%s" r)))) + +(defun slime-profile-package (package callers methods) + "Profile all functions in PACKAGE. +If CALLER is non-nil names have counts of the most common calling +functions recorded. +If METHODS is non-nil, profile all methods of all generic function +having names in the given package." + (interactive (list (slime-read-package-name "Package: ") + (y-or-n-p "Record the most common callers? ") + (y-or-n-p "Profile methods? "))) + (slime-eval-async `(swank:swank-profile-package ,package ,callers ,methods) + (lambda (r) (message "%s" r)))) + +(defun slime-profile-by-substring (substring &optional package) + "Profile all functions which names contain SUBSTRING. +If PACKAGE is NIL, then search in all packages." + (interactive (list + (slime-read-from-minibuffer + "Profile by matching substring: " + (slime-symbol-at-point)) + (slime-read-package-name "Package (RET for all packages): "))) + (let ((package (unless (equal package "") package))) + (slime-eval-async `(swank:profile-by-substring ,substring ,package) + (lambda (r) (message "%s" r)) ))) + +;;;; Documentation + +(defvar slime-documentation-lookup-function + 'slime-hyperspec-lookup) + +(defun slime-documentation-lookup () + "Generalized documentation lookup. Defaults to hyperspec lookup." + (interactive) + (call-interactively slime-documentation-lookup-function)) + +(defun slime-hyperspec-lookup (symbol-name) + "A wrapper for `hyperspec-lookup'" + (interactive (list (common-lisp-hyperspec-read-symbol-name + (slime-symbol-at-point)))) + (hyperspec-lookup symbol-name)) + +(defun slime-describe-symbol (symbol-name) + "Describe the symbol at point." + (interactive (list (slime-read-symbol-name "Describe symbol: "))) + (when (not symbol-name) + (error "No symbol given")) + (slime-eval-describe `(swank:describe-symbol ,symbol-name))) + +(defun slime-documentation (symbol-name) + "Display function- or symbol-documentation for SYMBOL-NAME." + (interactive (list (slime-read-symbol-name "Documentation for symbol: "))) + (when (not symbol-name) + (error "No symbol given")) + (slime-eval-describe + `(swank:documentation-symbol ,symbol-name))) + +(defun slime-describe-function (symbol-name) + (interactive (list (slime-read-symbol-name "Describe symbol's function: "))) + (when (not symbol-name) + (error "No symbol given")) + (slime-eval-describe `(swank:describe-function ,symbol-name))) + +(defface slime-apropos-symbol + '((t (:inherit bold))) + "Face for the symbol name in Apropos output." + :group 'slime) + +(defface slime-apropos-label + '((t (:inherit italic))) + "Face for label (`Function', `Variable' ...) in Apropos output." + :group 'slime) + +(defun slime-apropos-summary (string case-sensitive-p package only-external-p) + "Return a short description for the performed apropos search." + (concat (if case-sensitive-p "Case-sensitive " "") + "Apropos for " + (format "%S" string) + (if package (format " in package %S" package) "") + (if only-external-p " (external symbols only)" ""))) + +(defun slime-apropos (string &optional only-external-p package + case-sensitive-p) + "Show all bound symbols whose names match STRING. With prefix +arg, you're interactively asked for parameters of the search." + (interactive + (if current-prefix-arg + (list (read-string "SLIME Apropos: ") + (y-or-n-p "External symbols only? ") + (let ((pkg (slime-read-package-name "Package: "))) + (if (string= pkg "") nil pkg)) + (y-or-n-p "Case-sensitive? ")) + (list (read-string "SLIME Apropos: ") t nil nil))) + (let ((buffer-package (or package (slime-current-package)))) + (slime-eval-async + `(swank:apropos-list-for-emacs ,string ,only-external-p + ,case-sensitive-p ',package) + (slime-rcurry #'slime-show-apropos string buffer-package + (slime-apropos-summary string case-sensitive-p + package only-external-p))))) + +(defun slime-apropos-all () + "Shortcut for (slime-apropos <string> nil nil)" + (interactive) + (slime-apropos (read-string "SLIME Apropos: ") nil nil)) + +(defun slime-apropos-package (package &optional internal) + "Show apropos listing for symbols in PACKAGE. +With prefix argument include internal symbols." + (interactive (list (let ((pkg (slime-read-package-name "Package: "))) + (if (string= pkg "") (slime-current-package) pkg)) + current-prefix-arg)) + (slime-apropos "" (not internal) package)) + +(autoload 'apropos-mode "apropos") +(defun slime-show-apropos (plists string package summary) + (if (null plists) + (message "No apropos matches for %S" string) + (slime-with-popup-buffer ((slime-buffer-name :apropos) + :package package :connection t + :mode 'apropos-mode) + (if (boundp 'header-line-format) + (setq header-line-format summary) + (insert summary "\n\n")) + (slime-set-truncate-lines) + (slime-print-apropos plists) + (set-syntax-table lisp-mode-syntax-table) + (goto-char (point-min))))) + +(defvar slime-apropos-namespaces + '((:variable "Variable") + (:function "Function") + (:generic-function "Generic Function") + (:macro "Macro") + (:special-operator "Special Operator") + (:setf "Setf") + (:type "Type") + (:class "Class") + (:alien-type "Alien type") + (:alien-struct "Alien struct") + (:alien-union "Alien type") + (:alien-enum "Alien enum"))) + +(defun slime-print-apropos (plists) + (dolist (plist plists) + (let ((designator (plist-get plist :designator))) + (cl-assert designator) + (slime-insert-propertized `(face slime-apropos-symbol) designator)) + (terpri) + (cl-loop for (prop value) on plist by #'cddr + unless (eq prop :designator) do + (let ((namespace (cadr (or (assq prop slime-apropos-namespaces) + (error "Unknown property: %S" prop)))) + (start (point))) + (princ " ") + (slime-insert-propertized `(face slime-apropos-label) namespace) + (princ ": ") + (princ (cl-etypecase value + (string value) + ((member nil :not-documented) "(not documented)"))) + (add-text-properties + start (point) + (list 'type prop 'action 'slime-call-describer + 'button t 'apropos-label namespace + 'item (plist-get plist :designator))) + (terpri))))) + +(defun slime-call-describer (arg) + (let* ((pos (if (markerp arg) arg (point))) + (type (get-text-property pos 'type)) + (item (get-text-property pos 'item))) + (slime-eval-describe `(swank:describe-definition-for-emacs ,item ,type)))) + +(defun slime-info () + "Open Slime manual" + (interactive) + (let ((file (expand-file-name "doc/slime.info" slime-path))) + (if (file-exists-p file) + (info file) + (message "No slime.info, run `make slime.info' in %s" + (expand-file-name "doc/" slime-path))))) + + +;;;; XREF: cross-referencing + +(defvar slime-xref-mode-map) + +(define-derived-mode slime-xref-mode lisp-mode "Xref" + "slime-xref-mode: Major mode for cross-referencing. +\\<slime-xref-mode-map>\ +The most important commands: +\\[slime-xref-quit] - Dismiss buffer. +\\[slime-show-xref] - Display referenced source and keep xref window. +\\[slime-goto-xref] - Jump to referenced source and dismiss xref window. + +\\{slime-xref-mode-map} +\\{slime-popup-buffer-mode-map} +" + (slime-popup-buffer-mode) + (setq font-lock-defaults nil) + (setq delayed-mode-hooks nil) + (slime-mode -1)) + +(slime-define-keys slime-xref-mode-map + ((kbd "RET") 'slime-goto-xref) + ((kbd "SPC") 'slime-goto-xref) + ("v" 'slime-show-xref) + ("n" 'slime-xref-next-line) + ("p" 'slime-xref-prev-line) + ("." 'slime-xref-next-line) + ("," 'slime-xref-prev-line) + ("\C-c\C-c" 'slime-recompile-xref) + ("\C-c\C-k" 'slime-recompile-all-xrefs) + ("\M-," 'slime-xref-retract) + ([remap next-line] 'slime-xref-next-line) + ([remap previous-line] 'slime-xref-prev-line) + ) + + +;;;;; XREF results buffer and window management + +(cl-defmacro slime-with-xref-buffer ((_xref-type _symbol &optional package) + &body body) + "Execute BODY in a xref buffer, then show that buffer." + (declare (indent 1)) + `(slime-with-popup-buffer ((slime-buffer-name :xref) + :package ,package + :connection t + :select t + :mode 'slime-xref-mode) + (slime-set-truncate-lines) + ,@body)) + +(defun slime-insert-xrefs (xref-alist) + "Insert XREF-ALIST in the current-buffer. +XREF-ALIST is of the form ((GROUP . ((LABEL LOCATION) ...)) ...). +GROUP and LABEL are for decoration purposes. LOCATION is a +source-location." + (cl-loop for (group . refs) in xref-alist do + (slime-insert-propertized '(face bold) group "\n") + (cl-loop for (label location) in refs do + (slime-insert-propertized + (list 'slime-location location + 'face 'font-lock-keyword-face) + " " (slime-one-line-ify label) "\n"))) + ;; Remove the final newline to prevent accidental window-scrolling + (backward-delete-char 1)) + +(defun slime-xref-next-line () + (interactive) + (slime-xref-show-location (slime-search-property 'slime-location))) + +(defun slime-xref-prev-line () + (interactive) + (slime-xref-show-location (slime-search-property 'slime-location t))) + +(defun slime-xref-show-location (loc) + (cl-ecase (car loc) + (:location (slime-show-source-location loc nil 1)) + (:error (message "%s" (cadr loc))) + ((nil)))) + +(defvar slime-next-location-function nil + "Function to call for going to the next location.") + +(defvar slime-previous-location-function nil + "Function to call for going to the previous location.") + +(defvar slime-xref-last-buffer nil + "The most recent XREF results buffer. +This is used by `slime-goto-next-xref'") + +(defun slime-show-xref-buffer (xrefs _type _symbol package) + (slime-with-xref-buffer (_type _symbol package) + (slime-insert-xrefs xrefs) + (setq slime-next-location-function 'slime-goto-next-xref) + (setq slime-previous-location-function 'slime-goto-previous-xref) + (setq slime-xref-last-buffer (current-buffer)) + (goto-char (point-min)))) + +(defun slime-show-xrefs (xrefs type symbol package) + "Show the results of an XREF query." + (if (null xrefs) + (message "No references found for %s." symbol) + (slime-show-xref-buffer xrefs type symbol package))) + + +;;;;; XREF commands + +(defun slime-who-calls (symbol) + "Show all known callers of the function SYMBOL." + (interactive (list (slime-read-symbol-name "Who calls: " t))) + (slime-xref :calls symbol)) + +(defun slime-calls-who (symbol) + "Show all known functions called by the function SYMBOL." + (interactive (list (slime-read-symbol-name "Who calls: " t))) + (slime-xref :calls-who symbol)) + +(defun slime-who-references (symbol) + "Show all known referrers of the global variable SYMBOL." + (interactive (list (slime-read-symbol-name "Who references: " t))) + (slime-xref :references symbol)) + +(defun slime-who-binds (symbol) + "Show all known binders of the global variable SYMBOL." + (interactive (list (slime-read-symbol-name "Who binds: " t))) + (slime-xref :binds symbol)) + +(defun slime-who-sets (symbol) + "Show all known setters of the global variable SYMBOL." + (interactive (list (slime-read-symbol-name "Who sets: " t))) + (slime-xref :sets symbol)) + +(defun slime-who-macroexpands (symbol) + "Show all known expanders of the macro SYMBOL." + (interactive (list (slime-read-symbol-name "Who macroexpands: " t))) + (slime-xref :macroexpands symbol)) + +(defun slime-who-specializes (symbol) + "Show all known methods specialized on class SYMBOL." + (interactive (list (slime-read-symbol-name "Who specializes: " t))) + (slime-xref :specializes symbol)) + +(defun slime-list-callers (symbol-name) + "List the callers of SYMBOL-NAME in a xref window." + (interactive (list (slime-read-symbol-name "List callers: "))) + (slime-xref :callers symbol-name)) + +(defun slime-list-callees (symbol-name) + "List the callees of SYMBOL-NAME in a xref window." + (interactive (list (slime-read-symbol-name "List callees: "))) + (slime-xref :callees symbol-name)) + +;; FIXME: whats the call (slime-postprocess-xrefs result) good for? +(defun slime-xref (type symbol &optional continuation) + "Make an XREF request to Lisp." + (slime-eval-async + `(swank:xref ',type ',symbol) + (slime-rcurry (lambda (result type symbol package cont) + (slime-check-xref-implemented type result) + (let* ((_xrefs (slime-postprocess-xrefs result)) + (file-alist (cadr (slime-analyze-xrefs result)))) + (funcall (or cont 'slime-show-xrefs) + file-alist type symbol package))) + type + symbol + (slime-current-package) + continuation))) + +(defun slime-check-xref-implemented (type xrefs) + (when (eq xrefs :not-implemented) + (error "%s is not implemented yet on %s." + (slime-xref-type type) + (slime-lisp-implementation-name)))) + +(defun slime-xref-type (type) + (format "who-%s" (slime-cl-symbol-name type))) + +(defun slime-xrefs (types symbol &optional continuation) + "Make multiple XREF requests at once." + (slime-eval-async + `(swank:xrefs ',types ',symbol) + #'(lambda (result) + (funcall (or continuation + #'slime-show-xrefs) + (cl-loop for (key . val) in result + collect (cons (slime-xref-type key) val)) + types symbol (slime-current-package))))) + + +;;;;; XREF navigation + +(defun slime-xref-location-at-point () + (save-excursion + ;; When the end of the last line is at (point-max) we can't find + ;; the text property there. Going to bol avoids this problem. + (beginning-of-line 1) + (or (get-text-property (point) 'slime-location) + (error "No reference at point.")))) + +(defun slime-xref-dspec-at-point () + (save-excursion + (beginning-of-line 1) + (with-syntax-table lisp-mode-syntax-table + (forward-sexp) ; skip initial whitespaces + (backward-sexp) + (slime-sexp-at-point)))) + +(defun slime-all-xrefs () + (let ((xrefs nil)) + (save-excursion + (goto-char (point-min)) + (while (zerop (forward-line 1)) + (let ((loc (get-text-property (point) 'slime-location))) + (when loc + (let* ((dspec (slime-xref-dspec-at-point)) + (xref (make-slime-xref :dspec dspec :location loc))) + (push xref xrefs)))))) + (nreverse xrefs))) + +(defun slime-goto-xref () + "Goto the cross-referenced location at point." + (interactive) + (slime-show-xref) + (quit-window)) + +(defun slime-show-xref () + "Display the xref at point in the other window." + (interactive) + (let ((location (slime-xref-location-at-point))) + (slime-show-source-location location t 1))) + +(defun slime-goto-next-xref (&optional backward) + "Goto the next cross-reference location." + (if (not (buffer-live-p slime-xref-last-buffer)) + (error "No XREF buffer alive.") + (cl-destructuring-bind (location pos) + (with-current-buffer slime-xref-last-buffer + (list (slime-search-property 'slime-location backward) + (point))) + (cond ((slime-location-p location) + (slime-pop-to-location location) + ;; We do this here because changing the location can take + ;; a while when Emacs needs to read a file from disk. + (with-current-buffer slime-xref-last-buffer + (goto-char pos) + (slime-highlight-line 0.35))) + ((null location) + (message (if backward "No previous xref" "No next xref."))) + (t ; error location + (slime-goto-next-xref backward)))))) + +(defun slime-goto-previous-xref () + "Goto the previous cross-reference location." + (slime-goto-next-xref t)) + +(defun slime-search-property (prop &optional backward prop-value-fn) + "Search the next text range where PROP is non-nil. +Return the value of PROP. +If BACKWARD is non-nil, search backward. +If PROP-VALUE-FN is non-nil use it to extract PROP's value." + (let ((next-candidate (if backward + #'previous-single-char-property-change + #'next-single-char-property-change)) + (prop-value-fn (or prop-value-fn + (lambda () + (get-text-property (point) prop)))) + (start (point)) + (prop-value)) + (while (progn + (goto-char (funcall next-candidate (point) prop)) + (not (or (setq prop-value (funcall prop-value-fn)) + (eobp) + (bobp))))) + (cond (prop-value) + (t (goto-char start) nil)))) + +(defun slime-next-location () + "Go to the next location, depending on context. +When displaying XREF information, this goes to the next reference." + (interactive) + (when (null slime-next-location-function) + (error "No context for finding locations.")) + (funcall slime-next-location-function)) + +(defun slime-previous-location () + "Go to the previous location, depending on context. +When displaying XREF information, this goes to the previous reference." + (interactive) + (when (null slime-previous-location-function) + (error "No context for finding locations.")) + (funcall slime-previous-location-function)) + +(defun slime-recompile-xref (&optional raw-prefix-arg) + (interactive "P") + (let ((slime-compilation-policy (slime-compute-policy raw-prefix-arg))) + (let ((location (slime-xref-location-at-point)) + (dspec (slime-xref-dspec-at-point))) + (slime-recompile-locations + (list location) + (slime-rcurry #'slime-xref-recompilation-cont + (list dspec) (current-buffer)))))) + +(defun slime-recompile-all-xrefs (&optional raw-prefix-arg) + (interactive "P") + (let ((slime-compilation-policy (slime-compute-policy raw-prefix-arg))) + (let ((dspecs) (locations)) + (dolist (xref (slime-all-xrefs)) + (when (slime-xref-has-location-p xref) + (push (slime-xref.dspec xref) dspecs) + (push (slime-xref.location xref) locations))) + (slime-recompile-locations + locations + (slime-rcurry #'slime-xref-recompilation-cont + dspecs (current-buffer)))))) + +(defun slime-xref-recompilation-cont (results dspecs buffer) + ;; Extreme long-windedness to insert status of recompilation; + ;; sometimes Elisp resembles more of an Ewwlisp. + + ;; FIXME: Should probably throw out the whole recompilation cruft + ;; anyway. -- helmut + ;; TODO: next iteration of fixme cleanup this is going in a contrib -- jt + (with-current-buffer buffer + (slime-compilation-finished (slime-aggregate-compilation-results results)) + (save-excursion + (slime-xref-insert-recompilation-flags + dspecs (cl-loop for r in results collect + (or (slime-compilation-result.successp r) + (and (slime-compilation-result.notes r) + :complained))))))) + +(defun slime-aggregate-compilation-results (results) + `(:compilation-result + ,(cl-reduce #'append (mapcar #'slime-compilation-result.notes results)) + ,(cl-every #'slime-compilation-result.successp results) + ,(cl-reduce #'+ (mapcar #'slime-compilation-result.duration results)))) + +(defun slime-xref-insert-recompilation-flags (dspecs compilation-results) + (let* ((buffer-read-only nil) + (max-column (slime-column-max))) + (goto-char (point-min)) + (cl-loop for dspec in dspecs + for result in compilation-results + do (save-excursion + (cl-loop for dspec2 = (progn (search-forward dspec) + (slime-xref-dspec-at-point)) + until (equal dspec2 dspec)) + (end-of-line) ; skip old status information. + (insert-char ?\ (1+ (- max-column (current-column)))) + (insert (format "[%s]" + (cl-case result + ((t) :success) + ((nil) :failure) + (t result)))))))) + + +;;;; Macroexpansion + +(define-minor-mode slime-macroexpansion-minor-mode + "SLIME mode for macroexpansion" + nil + " Macroexpand" + '(("g" . slime-macroexpand-again))) + +(cl-macrolet ((remap (from to) + `(dolist (mapping + (where-is-internal ,from slime-mode-map)) + (define-key slime-macroexpansion-minor-mode-map + mapping ,to)))) + (remap 'slime-macroexpand-1 'slime-macroexpand-1-inplace) + (remap 'slime-macroexpand-all 'slime-macroexpand-all-inplace) + (remap 'slime-compiler-macroexpand-1 'slime-compiler-macroexpand-1-inplace) + (remap 'slime-expand-1 + 'slime-expand-1-inplace) + (remap 'advertised-undo 'slime-macroexpand-undo) + (remap 'undo 'slime-macroexpand-undo)) + +(defun slime-macroexpand-undo (&optional arg) + (interactive) + ;; Emacs 22.x introduced `undo-only' which + ;; works by binding `undo-no-redo' to t. We do + ;; it this way so we don't break prior Emacs + ;; versions. + (cl-macrolet ((undo-only (arg) `(let ((undo-no-redo t)) (undo ,arg)))) + (let ((inhibit-read-only t)) + (when (fboundp 'slime-remove-edits) + (slime-remove-edits (point-min) (point-max))) + (undo-only arg)))) + +(defvar slime-eval-macroexpand-expression nil + "Specifies the last macroexpansion preformed. +This variable specifies both what was expanded and how.") + +(defun slime-eval-macroexpand (expander &optional string) + (let ((string (or string (slime-sexp-at-point-or-error)))) + (setq slime-eval-macroexpand-expression `(,expander ,string)) + (slime-eval-async slime-eval-macroexpand-expression + #'slime-initialize-macroexpansion-buffer))) + +(defun slime-macroexpand-again () + "Reperform the last macroexpansion." + (interactive) + (slime-eval-async slime-eval-macroexpand-expression + (slime-rcurry #'slime-initialize-macroexpansion-buffer + (current-buffer)))) + +(defun slime-initialize-macroexpansion-buffer (expansion &optional buffer) + (pop-to-buffer (or buffer (slime-create-macroexpansion-buffer))) + (setq buffer-undo-list nil) ; Get rid of undo information from + ; previous expansions. + (let ((inhibit-read-only t) + (buffer-undo-list t)) ; Make the initial insertion not be undoable. + (erase-buffer) + (insert expansion) + (goto-char (point-min)) + (font-lock-fontify-buffer))) + +(defun slime-create-macroexpansion-buffer () + (let ((name (slime-buffer-name :macroexpansion))) + (slime-with-popup-buffer (name :package t :connection t + :mode 'lisp-mode) + (slime-mode 1) + (slime-macroexpansion-minor-mode 1) + (setq font-lock-keywords-case-fold-search t) + (current-buffer)))) + +(defun slime-eval-macroexpand-inplace (expander) + "Substitute the sexp at point with its macroexpansion. + +NB: Does not affect slime-eval-macroexpand-expression" + (interactive) + (let* ((bounds (or (slime-bounds-of-sexp-at-point) + (user-error "No sexp at point")))) + (lexical-let* ((start (copy-marker (car bounds))) + (end (copy-marker (cdr bounds))) + (point (point)) + (package (slime-current-package)) + (buffer (current-buffer))) + (slime-eval-async + `(,expander ,(buffer-substring-no-properties start end)) + (lambda (expansion) + (with-current-buffer buffer + (let ((buffer-read-only nil)) + (when (fboundp 'slime-remove-edits) + (slime-remove-edits (point-min) (point-max))) + (goto-char start) + (delete-region start end) + (slime-insert-indented expansion) + (goto-char point)))))))) + +(defun slime-macroexpand-1 (&optional repeatedly) + "Display the macro expansion of the form starting at point. +The form is expanded with CL:MACROEXPAND-1 or, if a prefix +argument is given, with CL:MACROEXPAND." + (interactive "P") + (slime-eval-macroexpand + (if repeatedly 'swank:swank-macroexpand 'swank:swank-macroexpand-1))) + +(defun slime-macroexpand-1-inplace (&optional repeatedly) + (interactive "P") + (slime-eval-macroexpand-inplace + (if repeatedly 'swank:swank-macroexpand 'swank:swank-macroexpand-1))) + +(defun slime-macroexpand-all () + "Display the recursively macro expanded sexp starting at +point." + (interactive) + (slime-eval-macroexpand 'swank:swank-macroexpand-all)) + +(defun slime-macroexpand-all-inplace () + "Display the recursively macro expanded sexp starting at point." + (interactive) + (slime-eval-macroexpand-inplace 'swank:swank-macroexpand-all)) + +(defun slime-compiler-macroexpand-1 (&optional repeatedly) + "Display the compiler-macro expansion of sexp starting at point." + (interactive "P") + (slime-eval-macroexpand + (if repeatedly + 'swank:swank-compiler-macroexpand + 'swank:swank-compiler-macroexpand-1))) + +(defun slime-compiler-macroexpand-1-inplace (&optional repeatedly) + "Display the compiler-macro expansion of sexp starting at point." + (interactive "P") + (slime-eval-macroexpand-inplace + (if repeatedly + 'swank:swank-compiler-macroexpand + 'swank:swank-compiler-macroexpand-1))) + +(defun slime-expand-1 (&optional repeatedly) + "Display the macro expansion of the form starting at point. +The form is expanded with CL:MACROEXPAND-1 or, if a prefix +argument is given, with CL:MACROEXPAND. If the form denotes a +compiler macro, SWANK/BACKEND:COMPILER-MACROEXPAND or +SWANK/BACKEND:COMPILER-MACROEXPAND-1 are used instead." + (interactive "P") + (slime-eval-macroexpand + (if repeatedly + 'swank:swank-expand + 'swank:swank-expand-1))) + +(defun slime-expand-1-inplace (&optional repeatedly) + "Display the macro expansion of the form at point. +The form is expanded with CL:MACROEXPAND-1 or, if a prefix +argument is given, with CL:MACROEXPAND." + (interactive "P") + (slime-eval-macroexpand-inplace + (if repeatedly + 'swank:swank-expand + 'swank:swank-expand-1))) + +(defun slime-format-string-expand (&optional string) + "Expand the format-string at point and display it." + (interactive (list (or (and (not current-prefix-arg) + (slime-string-at-point)) + (slime-read-from-minibuffer "Expand format: " + (slime-string-at-point))))) + (slime-eval-macroexpand 'swank:swank-format-string-expand string)) + + +;;;; Subprocess control + +(defun slime-interrupt () + "Interrupt Lisp." + (interactive) + (cond ((slime-use-sigint-for-interrupt) (slime-send-sigint)) + (t (slime-dispatch-event `(:emacs-interrupt ,slime-current-thread))))) + +(defun slime-quit () + (error "Not implemented properly. Use `slime-interrupt' instead.")) + +(defun slime-quit-lisp (&optional kill) + "Quit lisp, kill the inferior process and associated buffers." + (interactive "P") + (slime-quit-lisp-internal (slime-connection) 'slime-quit-sentinel kill)) + +(defun slime-quit-lisp-internal (connection sentinel kill) + (let ((slime-dispatching-connection connection)) + (slime-eval-async '(swank:quit-lisp)) + (let* ((process (slime-inferior-process connection))) + (set-process-filter connection nil) + (set-process-sentinel connection sentinel) + (when (and kill process) + (sleep-for 0.2) + (unless (memq (process-status process) '(exit signal)) + (kill-process process)))))) + +(defun slime-quit-sentinel (process _message) + (cl-assert (process-status process) 'closed) + (let* ((inferior (slime-inferior-process process)) + (inferior-buffer (if inferior (process-buffer inferior)))) + (when inferior (delete-process inferior)) + (when inferior-buffer (kill-buffer inferior-buffer)) + (slime-net-close process) + (message "Connection closed."))) + + +;;;; Debugger (SLDB) + +(defvar sldb-hook nil + "Hook run on entry to the debugger.") + +(defcustom sldb-initial-restart-limit 6 + "Maximum number of restarts to display initially." + :group 'slime-debugger + :type 'integer) + + +;;;;; Local variables in the debugger buffer + +;; Small helper. +(defun slime-make-variables-buffer-local (&rest variables) + (mapcar #'make-variable-buffer-local variables)) + +(slime-make-variables-buffer-local + (defvar sldb-condition nil + "A list (DESCRIPTION TYPE) describing the condition being debugged.") + + (defvar sldb-restarts nil + "List of (NAME DESCRIPTION) for each available restart.") + + (defvar sldb-level nil + "Current debug level (recursion depth) displayed in buffer.") + + (defvar sldb-backtrace-start-marker nil + "Marker placed at the first frame of the backtrace.") + + (defvar sldb-restart-list-start-marker nil + "Marker placed at the first restart in the restart list.") + + (defvar sldb-continuations nil + "List of ids for pending continuation.")) + +;;;;; SLDB macros + +;; some macros that we need to define before the first use + +(defmacro sldb-in-face (name string) + "Return STRING propertised with face sldb-NAME-face." + (declare (indent 1)) + (let ((facename (intern (format "sldb-%s-face" (symbol-name name)))) + (var (cl-gensym "string"))) + `(let ((,var ,string)) + (slime-add-face ',facename ,var) + ,var))) + + +;;;;; sldb-mode + +(defvar sldb-mode-syntax-table + (let ((table (copy-syntax-table lisp-mode-syntax-table))) + ;; We give < and > parenthesis syntax, so that #< ... > is treated + ;; as a balanced expression. This enables autodoc-mode to match + ;; #<unreadable> actual arguments in the backtraces with formal + ;; arguments of the function. (For Lisp mode, this is not + ;; desirable, since we do not wish to get a mismatched paren + ;; highlighted everytime we type < or >.) + (modify-syntax-entry ?< "(" table) + (modify-syntax-entry ?> ")" table) + table) + "Syntax table for SLDB mode.") + +(define-derived-mode sldb-mode fundamental-mode "sldb" + "Superior lisp debugger mode. +In addition to ordinary SLIME commands, the following are +available:\\<sldb-mode-map> + +Commands to examine the selected frame: + \\[sldb-toggle-details] - toggle details (local bindings, CATCH tags) + \\[sldb-show-source] - view source for the frame + \\[sldb-eval-in-frame] - eval in frame + \\[sldb-pprint-eval-in-frame] - eval in frame, pretty-print result + \\[sldb-disassemble] - disassemble + \\[sldb-inspect-in-frame] - inspect + +Commands to invoke restarts: + \\[sldb-quit] - quit + \\[sldb-abort] - abort + \\[sldb-continue] - continue + \\[sldb-invoke-restart-0]-\\[sldb-invoke-restart-9] - restart shortcuts + \\[sldb-invoke-restart-by-name] - invoke restart by name + +Commands to navigate frames: + \\[sldb-down] - down + \\[sldb-up] - up + \\[sldb-details-down] - down, with details + \\[sldb-details-up] - up, with details + \\[sldb-cycle] - cycle between restarts & backtrace + \\[sldb-beginning-of-backtrace] - beginning of backtrace + \\[sldb-end-of-backtrace] - end of backtrace + +Miscellaneous commands: + \\[sldb-restart-frame] - restart frame + \\[sldb-return-from-frame] - return from frame + \\[sldb-step] - step + \\[sldb-break-with-default-debugger] - switch to native debugger + \\[sldb-break-with-system-debugger] - switch to system debugger (gdb) + \\[slime-interactive-eval] - eval + \\[sldb-inspect-condition] - inspect signalled condition + +Full list of commands: + +\\{sldb-mode-map}" + (erase-buffer) + (set-syntax-table sldb-mode-syntax-table) + (slime-set-truncate-lines) + ;; Make original slime-connection "sticky" for SLDB commands in this buffer + (setq slime-buffer-connection (slime-connection))) + +(set-keymap-parent sldb-mode-map slime-parent-map) + +(slime-define-keys sldb-mode-map + + ((kbd "RET") 'sldb-default-action) + ("\C-m" 'sldb-default-action) + ([return] 'sldb-default-action) + ([mouse-2] 'sldb-default-action/mouse) + ([follow-link] 'mouse-face) + ("\C-i" 'sldb-cycle) + ("h" 'describe-mode) + ("v" 'sldb-show-source) + ("e" 'sldb-eval-in-frame) + ("d" 'sldb-pprint-eval-in-frame) + ("D" 'sldb-disassemble) + ("i" 'sldb-inspect-in-frame) + ("n" 'sldb-down) + ("p" 'sldb-up) + ("\M-n" 'sldb-details-down) + ("\M-p" 'sldb-details-up) + ("<" 'sldb-beginning-of-backtrace) + (">" 'sldb-end-of-backtrace) + ("t" 'sldb-toggle-details) + ("r" 'sldb-restart-frame) + ("I" 'sldb-invoke-restart-by-name) + ("R" 'sldb-return-from-frame) + ("c" 'sldb-continue) + ("s" 'sldb-step) + ("x" 'sldb-next) + ("o" 'sldb-out) + ("b" 'sldb-break-on-return) + ("a" 'sldb-abort) + ("q" 'sldb-quit) + ("A" 'sldb-break-with-system-debugger) + ("B" 'sldb-break-with-default-debugger) + ("P" 'sldb-print-condition) + ("C" 'sldb-inspect-condition) + (":" 'slime-interactive-eval) + ("\C-c\C-c" 'sldb-recompile-frame-source)) + +;; Keys 0-9 are shortcuts to invoke particular restarts. +(dotimes (number 10) + (let ((fname (intern (format "sldb-invoke-restart-%S" number))) + (docstring (format "Invoke restart numbered %S." number))) + (eval `(defun ,fname () + ,docstring + (interactive) + (sldb-invoke-restart ,number))) + (define-key sldb-mode-map (number-to-string number) fname))) + + +;;;;; SLDB buffer creation & update + +(defun sldb-buffers (&optional connection) + "Return a list of all sldb buffers (belonging to CONNECTION.)" + (if connection + (slime-filter-buffers (lambda () + (and (eq slime-buffer-connection connection) + (eq major-mode 'sldb-mode)))) + (slime-filter-buffers (lambda () (eq major-mode 'sldb-mode))))) + +(defun sldb-find-buffer (thread &optional connection) + (let ((connection (or connection (slime-connection)))) + (cl-find-if (lambda (buffer) + (with-current-buffer buffer + (and (eq slime-buffer-connection connection) + (eq slime-current-thread thread)))) + (sldb-buffers)))) + +(defun sldb-get-default-buffer () + "Get a sldb buffer. +The chosen buffer the default connection's it if exists." + (car (sldb-buffers slime-default-connection))) + +(defun sldb-get-buffer (thread &optional connection) + "Find or create a sldb-buffer for THREAD." + (let ((connection (or connection (slime-connection)))) + (or (sldb-find-buffer thread connection) + (let ((name (format "*sldb %s/%s*" (slime-connection-name) thread))) + (with-current-buffer (generate-new-buffer name) + (setq slime-buffer-connection connection + slime-current-thread thread) + (current-buffer)))))) + +(defun sldb-debugged-continuations (connection) + "Return the all debugged continuations for CONNECTION across SLDB buffers." + (cl-loop for b in (sldb-buffers) + append (with-current-buffer b + (and (eq slime-buffer-connection connection) + sldb-continuations)))) + +(defun sldb-setup (thread level condition restarts frames conts) + "Setup a new SLDB buffer. +CONDITION is a string describing the condition to debug. +RESTARTS is a list of strings (NAME DESCRIPTION) for each available restart. +FRAMES is a list (NUMBER DESCRIPTION &optional PLIST) describing the initial +portion of the backtrace. Frames are numbered from 0. +CONTS is a list of pending Emacs continuations." + (with-current-buffer (sldb-get-buffer thread) + (cl-assert (if (equal sldb-level level) + (equal sldb-condition condition) + t) + () "Bug: sldb-level is equal but condition differs\n%s\n%s" + sldb-condition condition) + (unless (equal sldb-level level) + (setq buffer-read-only nil) + (sldb-mode) + (setq slime-current-thread thread) + (setq sldb-level level) + (setq mode-name (format "sldb[%d]" sldb-level)) + (setq sldb-condition condition) + (setq sldb-restarts restarts) + (setq sldb-continuations conts) + (sldb-insert-condition condition) + (insert "\n\n" (sldb-in-face section "Restarts:") "\n") + (setq sldb-restart-list-start-marker (point-marker)) + (sldb-insert-restarts restarts 0 sldb-initial-restart-limit) + (insert "\n" (sldb-in-face section "Backtrace:") "\n") + (setq sldb-backtrace-start-marker (point-marker)) + (save-excursion + (if frames + (sldb-insert-frames (sldb-prune-initial-frames frames) t) + (insert "[No backtrace]"))) + (run-hooks 'sldb-hook) + (set-syntax-table lisp-mode-syntax-table)) + ;; FIXME: remove when dropping Emacs23 support + (let ((saved (selected-window))) + (pop-to-buffer (current-buffer)) + (set-window-parameter (selected-window) 'sldb-restore saved)) + (unless noninteractive ; needed for tests in batch-mode + (slime--display-region (point-min) (point))) + (setq buffer-read-only t) + (when (and slime-stack-eval-tags + ;; (y-or-n-p "Enter recursive edit? ") + ) + (message "Entering recursive edit..") + (recursive-edit)))) + +(defun sldb-activate (thread level select) + "Display the debugger buffer for THREAD. +If LEVEL isn't the same as in the buffer reinitialize the buffer." + (or (let ((buffer (sldb-find-buffer thread))) + (when buffer + (with-current-buffer buffer + (when (equal sldb-level level) + (when select (pop-to-buffer (current-buffer))) + t)))) + (sldb-reinitialize thread level))) + +(defun sldb-reinitialize (thread level) + (slime-rex (thread level) + ('(swank:debugger-info-for-emacs 0 10) + nil thread) + ((:ok result) + (apply #'sldb-setup thread level result)))) + +(defun sldb-exit (thread _level &optional stepping) + "Exit from the debug level LEVEL." + (let ((sldb (sldb-find-buffer thread))) + (when sldb + (with-current-buffer sldb + (cond (stepping + (setq sldb-level nil) + (run-with-timer 0.4 nil 'sldb-close-step-buffer sldb)) + ((not (eq sldb (window-buffer (selected-window)))) + ;; A different window selection means an indirect, + ;; non-interactive exit, we just kill the sldb buffer. + (kill-buffer)) + (t + ;; An interactive exit should restore configuration per + ;; `quit-window's protocol. FIXME: remove + ;; `previous-window' hack when dropping Emacs23 support + (let ((previous-window (window-parameter (selected-window) + 'sldb-restore))) + (quit-window t) + (if (and (not (>= emacs-major-version 24)) + (window-live-p previous-window)) + (select-window previous-window))))))))) + +(defun sldb-close-step-buffer (buffer) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (when (not sldb-level) + (quit-window t))))) + + +;;;;;; SLDB buffer insertion + +(defun sldb-insert-condition (condition) + "Insert the text for CONDITION. +CONDITION should be a list (MESSAGE TYPE EXTRAS). +EXTRAS is currently used for the stepper." + (cl-destructuring-bind (message type extras) condition + (slime-insert-propertized '(sldb-default-action sldb-inspect-condition) + (sldb-in-face topline message) + "\n" + (sldb-in-face condition type)) + (sldb-dispatch-extras extras))) + +(defvar sldb-extras-hooks) + +(defun sldb-dispatch-extras (extras) + ;; this is (mis-)used for the stepper + (dolist (extra extras) + (slime-dcase extra + ((:show-frame-source n) + (sldb-show-frame-source n)) + (t + (or (run-hook-with-args-until-success 'sldb-extras-hooks extra) + ;;(error "Unhandled extra element:" extra) + ))))) + +(defun sldb-insert-restarts (restarts start count) + "Insert RESTARTS and add the needed text props +RESTARTS should be a list ((NAME DESCRIPTION) ...)." + (let* ((len (length restarts)) + (end (if count (min (+ start count) len) len))) + (cl-loop for (name string) in (cl-subseq restarts start end) + for number from start + do (slime-insert-propertized + `(,@nil restart ,number + sldb-default-action sldb-invoke-restart + mouse-face highlight) + " " (sldb-in-face restart-number (number-to-string number)) + ": [" (sldb-in-face restart-type name) "] " + (sldb-in-face restart string)) + (insert "\n")) + (when (< end len) + (let ((pos (point))) + (slime-insert-propertized + (list 'sldb-default-action + (slime-rcurry #'sldb-insert-more-restarts restarts pos end)) + " --more--\n"))))) + +(defun sldb-insert-more-restarts (restarts position start) + (goto-char position) + (let ((inhibit-read-only t)) + (delete-region position (1+ (line-end-position))) + (sldb-insert-restarts restarts start nil))) + +(defun sldb-frame.string (frame) + (cl-destructuring-bind (_ str &optional _) frame str)) + +(defun sldb-frame.number (frame) + (cl-destructuring-bind (n _ &optional _) frame n)) + +(defun sldb-frame.plist (frame) + (cl-destructuring-bind (_ _ &optional plist) frame plist)) + +(defun sldb-frame-restartable-p (frame) + (and (plist-get (sldb-frame.plist frame) :restartable) t)) + +(defun sldb-prune-initial-frames (frames) + "Return the prefix of FRAMES to initially present to the user. +Regexp heuristics are used to avoid showing SWANK-internal frames." + (let* ((case-fold-search t) + (rx "^\\([() ]\\|lambda\\)*swank\\>")) + (or (cl-loop for frame in frames + until (string-match rx (sldb-frame.string frame)) + collect frame) + frames))) + +(defun sldb-insert-frames (frames more) + "Insert FRAMES into buffer. +If MORE is non-nil, more frames are on the Lisp stack." + (mapc #'sldb-insert-frame frames) + (when more + (slime-insert-propertized + `(,@nil sldb-default-action sldb-fetch-more-frames + sldb-previous-frame-number + ,(sldb-frame.number (cl-first (last frames))) + point-entered sldb-fetch-more-frames + start-open t + face sldb-section-face + mouse-face highlight) + " --more--") + (insert "\n"))) + +(defun sldb-compute-frame-face (frame) + (if (sldb-frame-restartable-p frame) + 'sldb-restartable-frame-line-face + 'sldb-frame-line-face)) + +(defun sldb-insert-frame (frame &optional face) + "Insert FRAME with FACE at point. +If FACE is nil, `sldb-compute-frame-face' is used to determine the face." + (setq face (or face (sldb-compute-frame-face frame))) + (let ((number (sldb-frame.number frame)) + (string (sldb-frame.string frame)) + (props `(frame ,frame sldb-default-action sldb-toggle-details))) + (slime-propertize-region props + (slime-propertize-region '(mouse-face highlight) + (insert " " (sldb-in-face frame-label (format "%2d:" number)) " ") + (slime-insert-indented + (slime-add-face face string))) + (insert "\n")))) + +(defun sldb-fetch-more-frames (&rest _) + "Fetch more backtrace frames. +Called on the `point-entered' text-property hook." + (let ((inhibit-point-motion-hooks t) + (inhibit-read-only t) + (prev (get-text-property (point) 'sldb-previous-frame-number))) + ;; we may be called twice, PREV is nil the second time + (when prev + (let* ((count 40) + (from (1+ prev)) + (to (+ from count)) + (frames (slime-eval `(swank:backtrace ,from ,to))) + (more (slime-length= frames count)) + (pos (point))) + (delete-region (line-beginning-position) (point-max)) + (sldb-insert-frames frames more) + (goto-char pos))))) + + +;;;;;; SLDB examining text props + +(defun sldb-restart-at-point () + (or (get-text-property (point) 'restart) + (error "No restart at point"))) + +(defun sldb-frame-number-at-point () + (let ((frame (get-text-property (point) 'frame))) + (cond (frame (car frame)) + (t (error "No frame at point"))))) + +(defun sldb-var-number-at-point () + (let ((var (get-text-property (point) 'var))) + (cond (var var) + (t (error "No variable at point"))))) + +(defun sldb-previous-frame-number () + (save-excursion + (sldb-backward-frame) + (sldb-frame-number-at-point))) + +(defun sldb-frame-details-visible-p () + (and (get-text-property (point) 'frame) + (get-text-property (point) 'details-visible-p))) + +(defun sldb-frame-region () + (slime-property-bounds 'frame)) + +(defun sldb-forward-frame () + (goto-char (next-single-char-property-change (point) 'frame))) + +(defun sldb-backward-frame () + (when (> (point) sldb-backtrace-start-marker) + (goto-char (previous-single-char-property-change + (if (get-text-property (point) 'frame) + (car (sldb-frame-region)) + (point)) + 'frame + nil sldb-backtrace-start-marker)))) + +(defun sldb-goto-last-frame () + (goto-char (point-max)) + (while (not (get-text-property (point) 'frame)) + (goto-char (previous-single-property-change (point) 'frame)) + ;; Recenter to bottom of the window; -2 to account for the + ;; empty last line displayed in sldb buffers. + (recenter -2))) + +(defun sldb-beginning-of-backtrace () + "Goto the first frame." + (interactive) + (goto-char sldb-backtrace-start-marker)) + + +;;;;;; SLDB recenter & redisplay +;; not sure yet, whether this is a good idea. +;; +;; jt: seconded. Only `sldb-show-frame-details' and +;; `sldb-hide-frame-details' use this. They could avoid it by not +;; removing and reinserting the frame's name line. +(defmacro slime-save-coordinates (origin &rest body) + "Restore line and column relative to ORIGIN, after executing BODY. + +This is useful if BODY deletes and inserts some text but we want to +preserve the current row and column as closely as possible." + (let ((base (make-symbol "base")) + (goal (make-symbol "goal")) + (mark (make-symbol "mark"))) + `(let* ((,base ,origin) + (,goal (slime-coordinates ,base)) + (,mark (point-marker))) + (set-marker-insertion-type ,mark t) + (prog1 (save-excursion ,@body) + (slime-restore-coordinate ,base ,goal ,mark))))) + +(put 'slime-save-coordinates 'lisp-indent-function 1) + +(defun slime-coordinates (origin) + ;; Return a pair (X . Y) for the column and line distance to ORIGIN. + (let ((y (slime-count-lines origin (point))) + (x (save-excursion + (- (current-column) + (progn (goto-char origin) (current-column)))))) + (cons x y))) + +(defun slime-restore-coordinate (base goal limit) + ;; Move point to GOAL. Coordinates are relative to BASE. + ;; Don't move beyond LIMIT. + (save-restriction + (narrow-to-region base limit) + (goto-char (point-min)) + (let ((col (current-column))) + (forward-line (cdr goal)) + (when (and (eobp) (bolp) (not (bobp))) + (backward-char)) + (move-to-column (+ col (car goal)))))) + +(defun slime-count-lines (start end) + "Return the number of lines between START and END. +This is 0 if START and END at the same line." + (- (count-lines start end) + (if (save-excursion (goto-char end) (bolp)) 0 1))) + + +;;;;; SLDB commands + +(defun sldb-default-action () + "Invoke the action at point." + (interactive) + (let ((fn (get-text-property (point) 'sldb-default-action))) + (if fn (funcall fn)))) + +(defun sldb-default-action/mouse (event) + "Invoke the action pointed at by the mouse." + (interactive "e") + (cl-destructuring-bind (_mouse-1 (_w pos &rest ignore)) event + (save-excursion + (goto-char pos) + (let ((fn (get-text-property (point) 'sldb-default-action))) + (if fn (funcall fn)))))) + +(defun sldb-cycle () + "Cycle between restart list and backtrace." + (interactive) + (let ((pt (point))) + (cond ((< pt sldb-restart-list-start-marker) + (goto-char sldb-restart-list-start-marker)) + ((< pt sldb-backtrace-start-marker) + (goto-char sldb-backtrace-start-marker)) + (t + (goto-char sldb-restart-list-start-marker))))) + +(defun sldb-end-of-backtrace () + "Fetch the entire backtrace and go to the last frame." + (interactive) + (sldb-fetch-all-frames) + (sldb-goto-last-frame)) + +(defun sldb-fetch-all-frames () + (let ((inhibit-read-only t) + (inhibit-point-motion-hooks t)) + (sldb-goto-last-frame) + (let ((last (sldb-frame-number-at-point))) + (goto-char (next-single-char-property-change (point) 'frame)) + (delete-region (point) (point-max)) + (save-excursion + (sldb-insert-frames (slime-eval `(swank:backtrace ,(1+ last) nil)) + nil))))) + + +;;;;;; SLDB show source + +(defun sldb-show-source () + "Highlight the frame at point's expression in a source code buffer." + (interactive) + (sldb-show-frame-source (sldb-frame-number-at-point))) + +(defun sldb-show-frame-source (frame-number) + (slime-eval-async + `(swank:frame-source-location ,frame-number) + (lambda (source-location) + (slime-dcase source-location + ((:error message) + (message "%s" message) + (ding)) + (t + (slime-show-source-location source-location t nil)))))) + +(defun slime-show-source-location (source-location + &optional highlight recenter-arg) + "Go to SOURCE-LOCATION and display the buffer in the other window." + (slime-goto-source-location source-location) + ;; show the location, but don't hijack focus. + (slime--display-position (point) t recenter-arg) + (when highlight (slime-highlight-sexp))) + +(defun slime--display-position (pos other-window recenter-arg) + (with-selected-window (display-buffer (current-buffer) other-window) + (goto-char pos) + (recenter recenter-arg))) + +;; Set window-start so that the region from START to END becomes visible. +;; START is inclusive; END is exclusive. +(defun slime--adjust-window-start (start end) + (let* ((last (max start (1- end))) + (window-height (window-text-height)) + (region-height (count-screen-lines start last t))) + ;; if needed, make the region visible + (when (or (not (pos-visible-in-window-p start)) + (not (pos-visible-in-window-p last))) + (let* ((nlines (cond ((or (< start (window-start)) + (>= region-height window-height)) + 0) + (t + (- region-height))))) + (goto-char start) + (recenter nlines))) + (cl-assert (pos-visible-in-window-p start)) + (cl-assert (or (pos-visible-in-window-p last) + (> region-height window-height))) + (cl-assert (pos-visible-in-window-p (1- (window-end nil t)) nil t)))) + +;; move POS to visible region +(defun slime--adjust-window-point (pos) + (cond ((pos-visible-in-window-p pos) + (goto-char pos)) + ((< pos (window-start)) + (goto-char (window-start))) + (t + (goto-char (1- (window-end nil t))) + (move-to-column 0))) + (cl-assert (pos-visible-in-window-p (point) nil t))) + +(defun slime--display-region (start end) + "Make the region from START to END visible. +Minimize point motion." + (cl-assert (<= start end)) + (cl-assert (eq (window-buffer (selected-window)) + (current-buffer))) + (let ((pos (point))) + (slime--adjust-window-start start end) + (slime--adjust-window-point pos))) + +(defun slime-highlight-sexp (&optional start end) + "Highlight the first sexp after point." + (let ((start (or start (point))) + (end (or end (save-excursion (ignore-errors (forward-sexp)) (point))))) + (slime-flash-region start end))) + +(defun slime-highlight-line (&optional timeout) + (slime-flash-region (+ (line-beginning-position) (current-indentation)) + (line-end-position) + timeout)) + + +;;;;;; SLDB toggle details + +(defun sldb-toggle-details (&optional on) + "Toggle display of details for the current frame. +The details include local variable bindings and CATCH-tags." + (interactive) + (cl-assert (sldb-frame-number-at-point)) + (let ((inhibit-read-only t) + (inhibit-point-motion-hooks t)) + (if (or on (not (sldb-frame-details-visible-p))) + (sldb-show-frame-details) + (sldb-hide-frame-details)))) + +(defun sldb-show-frame-details () + ;; fetch and display info about local variables and catch tags + (cl-destructuring-bind (start end frame locals catches) (sldb-frame-details) + (slime-save-coordinates start + (delete-region start end) + (slime-propertize-region `(frame ,frame details-visible-p t) + (sldb-insert-frame frame (if (sldb-frame-restartable-p frame) + 'sldb-restartable-frame-line-face + ;; FIXME: can we somehow merge the two? + 'sldb-detailed-frame-line-face)) + (let ((indent1 " ") + (indent2 " ")) + (insert indent1 (sldb-in-face section + (if locals "Locals:" "[No Locals]")) "\n") + (sldb-insert-locals locals indent2 frame) + (when catches + (insert indent1 (sldb-in-face section "Catch-tags:") "\n") + (dolist (tag catches) + (slime-propertize-region `(catch-tag ,tag) + (insert indent2 (sldb-in-face catch-tag (format "%s" tag)) + "\n")))) + (setq end (point))))) + (slime--display-region (point) end))) + +(defun sldb-frame-details () + ;; Return a list (START END FRAME LOCALS CATCHES) for frame at point. + (let* ((frame (get-text-property (point) 'frame)) + (num (car frame))) + (cl-destructuring-bind (start end) (sldb-frame-region) + (cl-list* start end frame + (slime-eval `(swank:frame-locals-and-catch-tags ,num)))))) + +(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." + (cl-loop for i from 0 + for var in vars do + (cl-destructuring-bind (&key name id value) var + (slime-propertize-region + (list 'sldb-default-action 'sldb-inspect-var 'var i) + (insert prefix + (sldb-in-face local-name + (concat name (if (zerop id) "" (format "#%d" id)))) + " = ") + (funcall sldb-insert-frame-variable-value-function + value frame i) + (insert "\n"))))) + +(defun sldb-insert-frame-variable-value (value _frame _index) + (insert (sldb-in-face local-value value))) + +(defun sldb-hide-frame-details () + ;; delete locals and catch tags, but keep the function name and args. + (cl-destructuring-bind (start end) (sldb-frame-region) + (let ((frame (get-text-property (point) 'frame))) + (slime-save-coordinates start + (delete-region start end) + (slime-propertize-region '(details-visible-p nil) + (sldb-insert-frame frame)))))) + +(defun sldb-disassemble () + "Disassemble the code for the current frame." + (interactive) + (let ((frame (sldb-frame-number-at-point))) + (slime-eval-async `(swank:sldb-disassemble ,frame) + (lambda (result) + (slime-show-description result nil))))) + + +;;;;;; SLDB eval and inspect + +(defun sldb-eval-in-frame (frame string package) + "Prompt for an expression and evaluate it in the selected frame." + (interactive (sldb-read-form-for-frame "Eval in frame (%s)> ")) + (slime-eval-async `(swank:eval-string-in-frame ,string ,frame ,package) + (if current-prefix-arg + 'slime-write-string + 'slime-display-eval-result))) + +(defun sldb-pprint-eval-in-frame (frame string package) + "Prompt for an expression, evaluate in selected frame, pretty-print result." + (interactive (sldb-read-form-for-frame "Eval in frame (%s)> ")) + (slime-eval-async + `(swank:pprint-eval-string-in-frame ,string ,frame ,package) + (lambda (result) + (slime-show-description result nil)))) + +(defun sldb-read-form-for-frame (fstring) + (let* ((frame (sldb-frame-number-at-point)) + (pkg (slime-eval `(swank:frame-package-name ,frame)))) + (list frame + (let ((slime-buffer-package pkg)) + (slime-read-from-minibuffer (format fstring pkg))) + pkg))) + +(defun sldb-inspect-in-frame (string) + "Prompt for an expression and inspect it in the selected frame." + (interactive (list (slime-read-from-minibuffer + "Inspect in frame (evaluated): " + (slime-sexp-at-point)))) + (let ((number (sldb-frame-number-at-point))) + (slime-eval-async `(swank:inspect-in-frame ,string ,number) + 'slime-open-inspector))) + +(defun sldb-inspect-var () + (let ((frame (sldb-frame-number-at-point)) + (var (sldb-var-number-at-point))) + (slime-eval-async `(swank:inspect-frame-var ,frame ,var) + 'slime-open-inspector))) + +(defun sldb-inspect-condition () + "Inspect the current debugger condition." + (interactive) + (slime-eval-async '(swank:inspect-current-condition) + 'slime-open-inspector)) + +(defun sldb-print-condition () + (interactive) + (slime-eval-describe `(swank:sdlb-print-condition))) + + +;;;;;; SLDB movement + +(defun sldb-down () + "Select next frame." + (interactive) + (sldb-forward-frame)) + +(defun sldb-up () + "Select previous frame." + (interactive) + (sldb-backward-frame) + (when (= (point) sldb-backtrace-start-marker) + (recenter (1+ (count-lines (point-min) (point)))))) + +(defun sldb-sugar-move (move-fn) + (let ((inhibit-read-only t)) + (when (sldb-frame-details-visible-p) (sldb-hide-frame-details)) + (funcall move-fn) + (sldb-show-source) + (sldb-toggle-details t))) + +(defun sldb-details-up () + "Select previous frame and show details." + (interactive) + (sldb-sugar-move 'sldb-up)) + +(defun sldb-details-down () + "Select next frame and show details." + (interactive) + (sldb-sugar-move 'sldb-down)) + + +;;;;;; SLDB restarts + +(defun sldb-quit () + "Quit to toplevel." + (interactive) + (cl-assert sldb-restarts () "sldb-quit called outside of sldb buffer") + (slime-rex () ('(swank:throw-to-toplevel)) + ((:ok x) (error "sldb-quit returned [%s]" x)) + ((:abort _)))) + +(defun sldb-continue () + "Invoke the \"continue\" restart." + (interactive) + (cl-assert sldb-restarts () "sldb-continue called outside of sldb buffer") + (slime-rex () + ('(swank:sldb-continue)) + ((:ok _) + (message "No restart named continue") + (ding)) + ((:abort _)))) + +(defun sldb-abort () + "Invoke the \"abort\" restart." + (interactive) + (slime-eval-async '(swank:sldb-abort) + (lambda (v) (message "Restart returned: %S" v)))) + +(defun sldb-invoke-restart (&optional number) + "Invoke a restart. +Optional NUMBER (index into `sldb-restarts') specifies the +restart to invoke, otherwise use the restart at point." + (interactive) + (let ((restart (or number (sldb-restart-at-point)))) + (slime-rex () + ((list 'swank:invoke-nth-restart-for-emacs sldb-level restart)) + ((:ok value) (message "Restart returned: %s" value)) + ((:abort _))))) + +(defun sldb-invoke-restart-by-name (restart-name) + (interactive (list (let ((completion-ignore-case t)) + (completing-read "Restart: " sldb-restarts nil t + "" + 'sldb-invoke-restart-by-name)))) + (sldb-invoke-restart (cl-position restart-name sldb-restarts + :test 'string= :key 'first))) + +(defun sldb-break-with-default-debugger (&optional dont-unwind) + "Enter default debugger." + (interactive "P") + (slime-rex () + ((list 'swank:sldb-break-with-default-debugger + (not (not dont-unwind))) + nil slime-current-thread) + ((:abort _)))) + +(defun sldb-break-with-system-debugger (&optional lightweight) + "Enter system debugger (gdb)." + (interactive "P") + (slime-attach-gdb slime-buffer-connection lightweight)) + +(defun slime-attach-gdb (connection &optional lightweight) + "Run `gud-gdb'on the connection with PID `pid'. + +If `lightweight' is given, do not send any request to the +inferior Lisp (e.g. to obtain default gdb config) but only +operate from the Emacs side; intended for cases where the Lisp is +truly screwed up." + (interactive + (list (slime-read-connection "Attach gdb to: " (slime-connection)) "P")) + (let ((pid (slime-pid connection)) + (file (slime-lisp-implementation-program connection)) + (commands (unless lightweight + (let ((slime-dispatching-connection connection)) + (slime-eval `(swank:gdb-initial-commands)))))) + (gud-gdb (format "gdb -p %d %s" pid (or file ""))) + (with-current-buffer gud-comint-buffer + (dolist (cmd commands) + ;; First wait until gdb was initialized, then wait until current + ;; command was processed. + (while (not (looking-back comint-prompt-regexp nil)) + (sit-for 0.01)) + ;; We do not use `gud-call' because we want the initial commands + ;; to be displayed by the user so he knows what he's got. + (insert cmd) + (comint-send-input))))) + +(defun slime-read-connection (prompt &optional initial-value) + "Read a connection from the minibuffer. +Return the net process, or nil." + (cl-assert (memq initial-value slime-net-processes)) + (let* ((to-string (lambda (p) + (format "%s (pid %d)" + (slime-connection-name p) (slime-pid p)))) + (candidates (mapcar (lambda (p) (cons (funcall to-string p) p)) + slime-net-processes))) + (cdr (assoc (completing-read prompt candidates + nil t (funcall to-string initial-value)) + candidates)))) + +(defun sldb-step () + "Step to next basic-block boundary." + (interactive) + (let ((frame (sldb-frame-number-at-point))) + (slime-eval-async `(swank:sldb-step ,frame)))) + +(defun sldb-next () + "Step over call." + (interactive) + (let ((frame (sldb-frame-number-at-point))) + (slime-eval-async `(swank:sldb-next ,frame)))) + +(defun sldb-out () + "Resume stepping after returning from this function." + (interactive) + (let ((frame (sldb-frame-number-at-point))) + (slime-eval-async `(swank:sldb-out ,frame)))) + +(defun sldb-break-on-return () + "Set a breakpoint at the current frame. +The debugger is entered when the frame exits." + (interactive) + (let ((frame (sldb-frame-number-at-point))) + (slime-eval-async `(swank:sldb-break-on-return ,frame) + (lambda (msg) (message "%s" msg))))) + +(defun sldb-break (name) + "Set a breakpoint at the start of the function NAME." + (interactive (list (slime-read-symbol-name "Function: " t))) + (slime-eval-async `(swank:sldb-break ,name) + (lambda (msg) (message "%s" msg)))) + +(defun sldb-return-from-frame (string) + "Reads an expression in the minibuffer and causes the function to +return that value, evaluated in the context of the frame." + (interactive (list (slime-read-from-minibuffer "Return from frame: "))) + (let* ((number (sldb-frame-number-at-point))) + (slime-rex () + ((list 'swank:sldb-return-from-frame number string)) + ((:ok value) (message "%s" value)) + ((:abort _))))) + +(defun sldb-restart-frame () + "Causes the frame to restart execution with the same arguments as it +was called originally." + (interactive) + (let* ((number (sldb-frame-number-at-point))) + (slime-rex () + ((list 'swank:restart-frame number)) + ((:ok value) (message "%s" value)) + ((:abort _))))) + +(defun slime-toggle-break-on-signals () + "Toggle the value of *break-on-signals*." + (interactive) + (slime-eval-async `(swank:toggle-break-on-signals) + (lambda (msg) (message "%s" msg)))) + + +;;;;;; SLDB recompilation commands + +(defun sldb-recompile-frame-source (&optional raw-prefix-arg) + (interactive "P") + (slime-eval-async + `(swank:frame-source-location ,(sldb-frame-number-at-point)) + (lexical-let ((policy (slime-compute-policy raw-prefix-arg))) + (lambda (source-location) + (slime-dcase source-location + ((:error message) + (message "%s" message) + (ding)) + (t + (let ((slime-compilation-policy policy)) + (slime-recompile-location source-location)))))))) + + +;;;; Thread control panel + +(defvar slime-threads-buffer-name (slime-buffer-name :threads)) +(defvar slime-threads-buffer-timer nil) + +(defcustom slime-threads-update-interval nil + "Interval at which the list of threads will be updated." + :type '(choice + (number :value 0.5) + (const nil)) + :group 'slime-ui) + +(defun slime-list-threads () + "Display a list of threads." + (interactive) + (let ((name slime-threads-buffer-name)) + (slime-with-popup-buffer (name :connection t + :mode 'slime-thread-control-mode) + (slime-update-threads-buffer) + (goto-char (point-min)) + (when slime-threads-update-interval + (when slime-threads-buffer-timer + (cancel-timer slime-threads-buffer-timer)) + (setq slime-threads-buffer-timer + (run-with-timer + slime-threads-update-interval + slime-threads-update-interval + 'slime-update-threads-buffer)))))) + +(defun slime-quit-threads-buffer () + (when slime-threads-buffer-timer + (cancel-timer slime-threads-buffer-timer)) + (quit-window t) + (slime-eval-async `(swank:quit-thread-browser))) + +(defun slime-update-threads-buffer () + (interactive) + (with-current-buffer slime-threads-buffer-name + (slime-eval-async '(swank:list-threads) + 'slime-display-threads))) + +(defun slime-move-point (position) + "Move point in the current buffer and in the window the buffer is displayed." + (let ((window (get-buffer-window (current-buffer) t))) + (goto-char position) + (when window + (set-window-point window position)))) + +(defun slime-display-threads (threads) + (with-current-buffer slime-threads-buffer-name + (let* ((inhibit-read-only t) + (old-thread-id (get-text-property (point) 'thread-id)) + (old-line (line-number-at-pos)) + (old-column (current-column))) + (erase-buffer) + (slime-insert-threads threads) + (let ((new-line (cl-position old-thread-id (cdr threads) + :key #'car :test #'equal))) + (goto-char (point-min)) + (forward-line (or new-line old-line)) + (move-to-column old-column) + (slime-move-point (point)))))) + +(defun slime-transpose-lists (list-of-lists) + (let ((ncols (length (car list-of-lists)))) + (cl-loop for col-index below ncols + collect (cl-loop for row in list-of-lists + collect (elt row col-index))))) + +(defun slime-insert-table-row (line line-props col-props col-widths) + (slime-propertize-region line-props + (cl-loop for string in line + for col-prop in col-props + for width in col-widths do + (slime-insert-propertized col-prop string) + (insert-char ?\ (- width (length string)))))) + +(defun slime-insert-table (rows header row-properties column-properties) + "Insert a \"table\" so that the columns are nicely aligned." + (let* ((ncols (length header)) + (lines (cons header rows)) + (widths (cl-loop for columns in (slime-transpose-lists lines) + collect (1+ (cl-loop for cell in columns + maximize (length cell))))) + (header-line (with-temp-buffer + (slime-insert-table-row + header nil (make-list ncols nil) widths) + (buffer-string)))) + (cond ((boundp 'header-line-format) + (setq header-line-format header-line)) + (t (insert header-line "\n"))) + (cl-loop for line in rows for line-props in row-properties do + (slime-insert-table-row line line-props column-properties widths) + (insert "\n")))) + +(defvar slime-threads-table-properties + '(nil (face bold))) + +(defun slime-insert-threads (threads) + (let* ((labels (car threads)) + (threads (cdr threads)) + (header (cl-loop for label in labels collect + (capitalize (substring (symbol-name label) 1)))) + (rows (cl-loop for thread in threads collect + (cl-loop for prop in thread collect + (format "%s" prop)))) + (line-props (cl-loop for (id) in threads for i from 0 + collect `(thread-index ,i thread-id ,id))) + (col-props (cl-loop for nil in labels for i from 0 collect + (nth i slime-threads-table-properties)))) + (slime-insert-table rows header line-props col-props))) + + +;;;;; Major mode + +(define-derived-mode slime-thread-control-mode fundamental-mode + "Threads" + "SLIME Thread Control Panel Mode. + +\\{slime-thread-control-mode-map} +\\{slime-popup-buffer-mode-map}" + (when slime-truncate-lines + (set (make-local-variable 'truncate-lines) t)) + (setq buffer-undo-list t)) + +(slime-define-keys slime-thread-control-mode-map + ("a" 'slime-thread-attach) + ("d" 'slime-thread-debug) + ("g" 'slime-update-threads-buffer) + ("k" 'slime-thread-kill) + ("q" 'slime-quit-threads-buffer)) + +(defun slime-thread-kill () + (interactive) + (slime-eval `(cl:mapc 'swank:kill-nth-thread + ',(slime-get-properties 'thread-index))) + (call-interactively 'slime-update-threads-buffer)) + +(defun slime-get-region-properties (prop start end) + (cl-loop for position = (if (get-text-property start prop) + start + (next-single-property-change start prop)) + then (next-single-property-change position prop) + while (<= position end) + collect (get-text-property position prop))) + +(defun slime-get-properties (prop) + (if (use-region-p) + (slime-get-region-properties prop + (region-beginning) + (region-end)) + (let ((value (get-text-property (point) prop))) + (when value + (list value))))) + +(defun slime-thread-attach () + (interactive) + (let ((id (get-text-property (point) 'thread-index)) + (file (slime-swank-port-file))) + (slime-eval-async `(swank:start-swank-server-in-thread ,id ,file))) + (slime-read-port-and-connect nil)) + +(defun slime-thread-debug () + (interactive) + (let ((id (get-text-property (point) 'thread-index))) + (slime-eval-async `(swank:debug-nth-thread ,id)))) + + +;;;;; Connection listing + +(define-derived-mode slime-connection-list-mode fundamental-mode + "Slime-Connections" + "SLIME Connection List Mode. + +\\{slime-connection-list-mode-map} +\\{slime-popup-buffer-mode-map}" + (when slime-truncate-lines + (set (make-local-variable 'truncate-lines) t))) + +(slime-define-keys slime-connection-list-mode-map + ("d" 'slime-connection-list-make-default) + ("g" 'slime-update-connection-list) + ((kbd "C-k") 'slime-quit-connection-at-point) + ("R" 'slime-restart-connection-at-point)) + +(defun slime-connection-at-point () + (or (get-text-property (point) 'slime-connection) + (error "No connection at point"))) + +(defun slime-quit-connection-at-point (connection) + (interactive (list (slime-connection-at-point))) + (let ((slime-dispatching-connection connection) + (end (time-add (current-time) (seconds-to-time 3)))) + (slime-quit-lisp t) + (while (memq connection slime-net-processes) + (when (time-less-p end (current-time)) + (message "Quit timeout expired. Disconnecting.") + (delete-process connection)) + (sit-for 0 100))) + (slime-update-connection-list)) + +(defun slime-restart-connection-at-point (connection) + (interactive (list (slime-connection-at-point))) + (let ((slime-dispatching-connection connection)) + (slime-restart-inferior-lisp))) + +(defun slime-connection-list-make-default () + "Make the connection at point the default connection." + (interactive) + (slime-select-connection (slime-connection-at-point)) + (slime-update-connection-list)) + +(defvar slime-connections-buffer-name (slime-buffer-name :connections)) + +(defun slime-list-connections () + "Display a list of all connections." + (interactive) + (slime-with-popup-buffer (slime-connections-buffer-name + :mode 'slime-connection-list-mode) + (slime-draw-connection-list))) + +(defun slime-update-connection-list () + "Display a list of all connections." + (interactive) + (let ((pos (point)) + (inhibit-read-only t)) + (erase-buffer) + (slime-draw-connection-list) + (goto-char pos))) + +(defun slime-draw-connection-list () + (let ((default-pos nil) + (default slime-default-connection) + (fstring "%s%2s %-10s %-17s %-7s %-s\n")) + (insert (format fstring " " "Nr" "Name" "Port" "Pid" "Type") + (format fstring " " "--" "----" "----" "---" "----")) + (dolist (p (reverse slime-net-processes)) + (when (eq default p) (setf default-pos (point))) + (slime-insert-propertized + (list 'slime-connection p) + (format fstring + (if (eq default p) "*" " ") + (slime-connection-number p) + (slime-connection-name p) + (or (process-id p) (process-contact p)) + (slime-pid p) + (slime-lisp-implementation-type p)))) + (when default-pos + (goto-char default-pos)))) + + +;;;; Inspector + +(defgroup slime-inspector nil + "Inspector faces." + :prefix "slime-inspector-" + :group 'slime) + +(defface slime-inspector-topline-face + '((t ())) + "Face for top line describing object." + :group 'slime-inspector) + +(defface slime-inspector-label-face + '((t (:inherit font-lock-constant-face))) + "Face for labels in the inspector." + :group 'slime-inspector) + +(defface slime-inspector-value-face + '((t (:inherit font-lock-builtin-face))) + "Face for things which can themselves be inspected." + :group 'slime-inspector) + +(defface slime-inspector-action-face + '((t (:inherit font-lock-warning-face))) + "Face for labels of inspector actions." + :group 'slime-inspector) + +(defface slime-inspector-type-face + '((t (:inherit font-lock-type-face))) + "Face for type description in inspector." + :group 'slime-inspector) + +(defvar slime-inspector-mark-stack '()) + +(defun slime-inspect (string) + "Eval an expression and inspect the result." + (interactive + (list (slime-read-from-minibuffer "Inspect value (evaluated): " + (slime-sexp-at-point)))) + (slime-eval-async `(swank:init-inspector ,string) 'slime-open-inspector)) + +(define-derived-mode slime-inspector-mode fundamental-mode + "Slime-Inspector" + " +\\{slime-inspector-mode-map} +\\{slime-popup-buffer-mode-map}" + (set-syntax-table lisp-mode-syntax-table) + (slime-set-truncate-lines) + (setq buffer-read-only t)) + +(defun slime-inspector-buffer () + (or (get-buffer (slime-buffer-name :inspector)) + (slime-with-popup-buffer ((slime-buffer-name :inspector) + :mode 'slime-inspector-mode) + (setq slime-inspector-mark-stack '()) + (buffer-disable-undo) + (current-buffer)))) + +(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 hook) + "Display INSPECTED-PARTS in a new inspector window. +Optionally set point to POINT. If HOOK is provided, it is added to local +KILL-BUFFER hooks for the inspector buffer." + (with-current-buffer (slime-inspector-buffer) + (when hook + (add-hook 'kill-buffer-hook hook t t)) + (setq slime-buffer-connection (slime-current-connection)) + (let ((inhibit-read-only t)) + (erase-buffer) + (pop-to-buffer (current-buffer)) + (cl-destructuring-bind (&key id title content) inspected-parts + (cl-macrolet ((fontify (face string) + `(slime-inspector-fontify ,face ,string))) + (slime-propertize-region + (list 'slime-part-number id + 'mouse-face 'highlight + 'face 'slime-inspector-value-face) + (insert title)) + (while (eq (char-before) ?\n) + (backward-delete-char 1)) + (insert "\n" (fontify label "--------------------") "\n") + (save-excursion + (slime-inspector-insert-content content)) + (when point + (cl-check-type point cons) + (ignore-errors + (goto-char (point-min)) + (forward-line (1- (car point))) + (move-to-column (cdr point))))))))) + +(defvar slime-inspector-limit 500) + +(defun slime-inspector-insert-content (content) + (slime-inspector-fetch-chunk + content nil + (lambda (chunk) + (let ((inhibit-read-only t)) + (slime-inspector-insert-chunk chunk t t))))) + +(defun slime-inspector-insert-chunk (chunk prev next) + "Insert CHUNK at point. +If PREV resp. NEXT are true insert more-buttons as needed." + (cl-destructuring-bind (ispecs len start end) chunk + (when (and prev (> start 0)) + (slime-inspector-insert-more-button start t)) + (mapc slime-inspector-insert-ispec-function ispecs) + (when (and next (< end len)) + (slime-inspector-insert-more-button end nil)))) + +(defun slime-inspector-insert-ispec (ispec) + (if (stringp ispec) + (insert ispec) + (slime-dcase ispec + ((:value string id) + (slime-propertize-region + (list 'slime-part-number id + 'mouse-face 'highlight + 'face 'slime-inspector-value-face) + (insert string))) + ((:label string) + (insert (slime-inspector-fontify label string))) + ((:action string id) + (slime-insert-propertized (list 'slime-action-number id + 'mouse-face 'highlight + 'face 'slime-inspector-action-face) + string))))) + +(defun slime-inspector-position () + "Return a pair (Y-POSITION X-POSITION) representing the +position of point in the current buffer." + ;; We make sure we return absolute coordinates even if the user has + ;; narrowed the buffer. + ;; FIXME: why would somebody narrow the buffer? + (save-restriction + (widen) + (cons (line-number-at-pos) + (current-column)))) + +(defun slime-inspector-property-at-point () + (let* ((properties '(slime-part-number slime-range-button + slime-action-number)) + (find-property + (lambda (point) + (cl-loop for property in properties + for value = (get-text-property point property) + when value + return (list property value))))) + (or (funcall find-property (point)) + (funcall find-property (1- (point)))))) + +(defun slime-inspector-operate-on-point () + "Invoke the command for the text at point. +1. If point is on a value then recursivly call the inspector on +that value. +2. If point is on an action then call that action. +3. If point is on a range-button fetch and insert the range." + (interactive) + (let ((opener (lexical-let ((point (slime-inspector-position))) + (lambda (parts) + (when parts + (slime-open-inspector parts point))))) + (new-opener (lambda (parts) + (when parts + (slime-open-inspector parts))))) + (cl-destructuring-bind (&optional property value) + (slime-inspector-property-at-point) + (cl-case property + (slime-part-number + (slime-eval-async `(swank:inspect-nth-part ,value) + new-opener) + (push (slime-inspector-position) slime-inspector-mark-stack)) + (slime-range-button + (slime-inspector-fetch-more value)) + (slime-action-number + (slime-eval-async `(swank::inspector-call-nth-action ,value) + opener)) + (t (error "No object at point")))))) + +(defun slime-inspector-operate-on-click (event) + "Move to events' position and operate the part." + (interactive "@e") + (let ((point (posn-point (event-end event)))) + (cond ((and point + (or (get-text-property point 'slime-part-number) + (get-text-property point 'slime-range-button) + (get-text-property point 'slime-action-number))) + (goto-char point) + (slime-inspector-operate-on-point)) + (t + (error "No clickable part here"))))) + +(defun slime-inspector-pop () + "Reinspect the previous object." + (interactive) + (slime-eval-async + `(swank:inspector-pop) + (lambda (result) + (cond (result + (slime-open-inspector result (pop slime-inspector-mark-stack))) + (t + (message "No previous object") + (ding)))))) + +(defun slime-inspector-next () + "Inspect the next object in the history." + (interactive) + (let ((result (slime-eval `(swank:inspector-next)))) + (cond (result + (push (slime-inspector-position) slime-inspector-mark-stack) + (slime-open-inspector result)) + (t (message "No next object") + (ding))))) + +(defun slime-inspector-quit () + "Quit the inspector and kill the buffer." + (interactive) + (slime-eval-async `(swank:quit-inspector)) + (quit-window t)) + +;; FIXME: first return value is just point. +;; FIXME: could probably use slime-search-property. +(defun slime-find-inspectable-object (direction limit) + "Find the next/previous inspectable object. +DIRECTION can be either 'next or 'prev. +LIMIT is the maximum or minimum position in the current buffer. + +Return a list of two values: If an object could be found, the +starting position of the found object and T is returned; +otherwise LIMIT and NIL is returned." + (let ((finder (cl-ecase direction + (next 'next-single-property-change) + (prev 'previous-single-property-change)))) + (let ((prop nil) (curpos (point))) + (while (and (not prop) (not (= curpos limit))) + (let ((newpos (funcall finder curpos 'slime-part-number nil limit))) + (setq prop (get-text-property newpos 'slime-part-number)) + (setq curpos newpos))) + (list curpos (and prop t))))) + +(defun slime-inspector-next-inspectable-object (arg) + "Move point to the next inspectable object. +With optional ARG, move across that many objects. +If ARG is negative, move backwards." + (interactive "p") + (let ((maxpos (point-max)) (minpos (point-min)) + (previously-wrapped-p nil)) + ;; Forward. + (while (> arg 0) + (cl-destructuring-bind (pos foundp) + (slime-find-inspectable-object 'next maxpos) + (if foundp + (progn (goto-char pos) (setq arg (1- arg)) + (setq previously-wrapped-p nil)) + (if (not previously-wrapped-p) ; cycle detection + (progn (goto-char minpos) (setq previously-wrapped-p t)) + (error "No inspectable objects"))))) + ;; Backward. + (while (< arg 0) + (cl-destructuring-bind (pos foundp) + (slime-find-inspectable-object 'prev minpos) + ;; SLIME-OPEN-INSPECTOR inserts the title of an inspector page + ;; as a presentation at the beginning of the buffer; skip + ;; that. (Notice how this problem can not arise in ``Forward.'') + (if (and foundp (/= pos minpos)) + (progn (goto-char pos) (setq arg (1+ arg)) + (setq previously-wrapped-p nil)) + (if (not previously-wrapped-p) ; cycle detection + (progn (goto-char maxpos) (setq previously-wrapped-p t)) + (error "No inspectable objects"))))))) + +(defun slime-inspector-previous-inspectable-object (arg) + "Move point to the previous inspectable object. +With optional ARG, move across that many objects. +If ARG is negative, move forwards." + (interactive "p") + (slime-inspector-next-inspectable-object (- arg))) + +(defun slime-inspector-describe () + (interactive) + (slime-eval-describe `(swank:describe-inspectee))) + +(defun slime-inspector-pprint (part) + (interactive (list (or (get-text-property (point) 'slime-part-number) + (error "No part at point")))) + (slime-eval-describe `(swank:pprint-inspector-part ,part))) + +(defun slime-inspector-eval (string) + "Eval an expression in the context of the inspected object." + (interactive (list (slime-read-from-minibuffer "Inspector eval: "))) + (slime-eval-with-transcript `(swank:inspector-eval ,string))) + +(defun slime-inspector-history () + "Show the previously inspected objects." + (interactive) + (slime-eval-describe `(swank:inspector-history))) + +(defun slime-inspector-show-source (part) + (interactive (list (or (get-text-property (point) 'slime-part-number) + (error "No part at point")))) + (slime-eval-async + `(swank:find-source-location-for-emacs '(:inspector ,part)) + #'slime-show-source-location)) + +(defun slime-inspector-reinspect () + (interactive) + (slime-eval-async `(swank:inspector-reinspect) + (lexical-let ((point (slime-inspector-position))) + (lambda (parts) + (slime-open-inspector parts point))))) + +(defun slime-inspector-toggle-verbose () + (interactive) + (slime-eval-async `(swank:inspector-toggle-verbose) + (lexical-let ((point (slime-inspector-position))) + (lambda (parts) + (slime-open-inspector parts point))))) + +(defun slime-inspector-insert-more-button (index previous) + (slime-insert-propertized + (list 'slime-range-button (list index previous) + 'mouse-face 'highlight + 'face 'slime-inspector-action-face) + (if previous " [--more--]\n" " [--more--]"))) + +(defun slime-inspector-fetch-all () + "Fetch all inspector contents and go to the end." + (interactive) + (goto-char (1- (point-max))) + (let ((button (get-text-property (point) 'slime-range-button))) + (when button + (let (slime-inspector-limit) + (slime-inspector-fetch-more button))))) + +(defun slime-inspector-fetch-more (button) + (cl-destructuring-bind (index prev) button + (slime-inspector-fetch-chunk + (list '() (1+ index) index index) prev + (slime-rcurry + (lambda (chunk prev) + (let ((inhibit-read-only t)) + (apply #'delete-region (slime-property-bounds 'slime-range-button)) + (slime-inspector-insert-chunk chunk prev (not prev)))) + prev)))) + +(defun slime-inspector-fetch-chunk (chunk prev cont) + (slime-inspector-fetch chunk slime-inspector-limit prev cont)) + +(defun slime-inspector-fetch (chunk limit prev cont) + (cl-destructuring-bind (from to) + (slime-inspector-next-range chunk limit prev) + (cond ((and from to) + (slime-eval-async + `(swank:inspector-range ,from ,to) + (slime-rcurry (lambda (chunk2 chunk1 limit prev cont) + (slime-inspector-fetch + (slime-inspector-join-chunks chunk1 chunk2) + limit prev cont)) + chunk limit prev cont))) + (t (funcall cont chunk))))) + +(defun slime-inspector-next-range (chunk limit prev) + (cl-destructuring-bind (_ len start end) chunk + (let ((count (- end start))) + (cond ((and prev (< 0 start) (or (not limit) (< count limit))) + (list (if limit (max (- end limit) 0) 0) start)) + ((and (not prev) (< end len) (or (not limit) (< count limit))) + (list end (if limit (+ start limit) most-positive-fixnum))) + (t '(nil nil)))))) + +(defun slime-inspector-join-chunks (chunk1 chunk2) + (cl-destructuring-bind (i1 _l1 s1 e1) chunk1 + (cl-destructuring-bind (i2 l2 s2 e2) chunk2 + (cond ((= e1 s2) + (list (append i1 i2) l2 s1 e2)) + ((= e2 s1) + (list (append i2 i1) l2 s2 e1)) + (t (error "Invalid chunks")))))) + +(set-keymap-parent slime-inspector-mode-map slime-parent-map) + +(slime-define-keys slime-inspector-mode-map + ([return] 'slime-inspector-operate-on-point) + ("\C-m" 'slime-inspector-operate-on-point) + ([mouse-1] 'slime-inspector-operate-on-click) + ([mouse-2] 'slime-inspector-operate-on-click) + ([mouse-6] 'slime-inspector-pop) + ([mouse-7] 'slime-inspector-next) + ("l" 'slime-inspector-pop) + ("n" 'slime-inspector-next) + (" " 'slime-inspector-next) + ("d" 'slime-inspector-describe) + ("p" 'slime-inspector-pprint) + ("e" 'slime-inspector-eval) + ("h" 'slime-inspector-history) + ("g" 'slime-inspector-reinspect) + ("v" 'slime-inspector-toggle-verbose) + ("\C-i" 'slime-inspector-next-inspectable-object) + ([(shift tab)] + 'slime-inspector-previous-inspectable-object) ; Emacs translates S-TAB + ([backtab] 'slime-inspector-previous-inspectable-object) ; to BACKTAB on X. + ("." 'slime-inspector-show-source) + (">" 'slime-inspector-fetch-all) + ("q" 'slime-inspector-quit)) + + +;;;; Buffer selector + +(defvar slime-selector-methods nil + "List of buffer-selection methods for the `slime-select' command. +Each element is a list (KEY DESCRIPTION FUNCTION). +DESCRIPTION is a one-line description of what the key selects.") + +(defvar slime-selector-other-window nil + "If non-nil use switch-to-buffer-other-window.") + +(defun slime-selector (&optional other-window) + "Select a new buffer by type, indicated by a single character. +The user is prompted for a single character indicating the method by +which to choose a new buffer. The `?' character describes the +available methods. + +See `def-slime-selector-method' for defining new methods." + (interactive) + (message "Select [%s]: " + (apply #'string (mapcar #'car slime-selector-methods))) + (let* ((slime-selector-other-window other-window) + (ch (save-window-excursion + (select-window (minibuffer-window)) + (read-char))) + (method (cl-find ch slime-selector-methods :key #'car))) + (cond (method + (funcall (cl-third method))) + (t + (message "No method for character: ?\\%c" ch) + (ding) + (sleep-for 1) + (discard-input) + (slime-selector))))) + +(defmacro def-slime-selector-method (key description &rest body) + "Define a new `slime-select' buffer selection method. + +KEY is the key the user will enter to choose this method. + +DESCRIPTION is a one-line sentence describing how the method +selects a buffer. + +BODY is a series of forms which are evaluated when the selector +is chosen. The returned buffer is selected with +switch-to-buffer." + (let ((method `(lambda () + (let ((buffer (progn ,@body))) + (cond ((not (get-buffer buffer)) + (message "No such buffer: %S" buffer) + (ding)) + ((get-buffer-window buffer) + (select-window (get-buffer-window buffer))) + (slime-selector-other-window + (switch-to-buffer-other-window buffer)) + (t + (switch-to-buffer buffer))))))) + `(setq slime-selector-methods + (cl-sort (cons (list ,key ,description ,method) + (cl-remove ,key slime-selector-methods :key #'car)) + #'< :key #'car)))) + +(def-slime-selector-method ?? "Selector help buffer." + (ignore-errors (kill-buffer "*Select Help*")) + (with-current-buffer (get-buffer-create "*Select Help*") + (insert "Select Methods:\n\n") + (cl-loop for (key line nil) in slime-selector-methods + do (insert (format "%c:\t%s\n" key line))) + (goto-char (point-min)) + (help-mode) + (display-buffer (current-buffer) t)) + (slime-selector) + (current-buffer)) + +(cl-pushnew (list ?4 "Select in other window" (lambda () (slime-selector t))) + slime-selector-methods :key #'car) + +(def-slime-selector-method ?q "Abort." + (top-level)) + +(def-slime-selector-method ?i + "*inferior-lisp* buffer." + (cond ((and (slime-connected-p) (slime-process)) + (process-buffer (slime-process))) + (t + "*inferior-lisp*"))) + +(def-slime-selector-method ?v + "*slime-events* buffer." + slime-event-buffer-name) + +(def-slime-selector-method ?l + "most recently visited lisp-mode buffer." + (slime-recently-visited-buffer 'lisp-mode)) + +(def-slime-selector-method ?d + "*sldb* buffer for the current connection." + (or (sldb-get-default-buffer) + (error "No debugger buffer"))) + +(def-slime-selector-method ?e + "most recently visited emacs-lisp-mode buffer." + (slime-recently-visited-buffer 'emacs-lisp-mode)) + +(def-slime-selector-method ?c + "SLIME connections buffer." + (slime-list-connections) + slime-connections-buffer-name) + +(def-slime-selector-method ?n + "Cycle to the next Lisp connection." + (slime-next-connection) + (concat "*slime-repl " + (slime-connection-name (slime-current-connection)) + "*")) + +(def-slime-selector-method ?p + "Cycle to the previous Lisp connection." + (slime-prev-connection) + (concat "*slime-repl " + (slime-connection-name (slime-current-connection)) + "*")) + +(def-slime-selector-method ?t + "SLIME threads buffer." + (slime-list-threads) + slime-threads-buffer-name) + +(defun slime-recently-visited-buffer (mode) + "Return the most recently visited buffer whose major-mode is MODE. +Only considers buffers that are not already visible." + (cl-loop for buffer in (buffer-list) + when (and (with-current-buffer buffer (eq major-mode mode)) + (not (string-match "^ " (buffer-name buffer))) + (null (get-buffer-window buffer 'visible))) + return buffer + finally (error "Can't find unshown buffer in %S" mode))) + + +;;;; Indentation + +(defun slime-update-indentation () + "Update indentation for all macros defined in the Lisp system." + (interactive) + (slime-eval-async '(swank:update-indentation-information))) + +(defvar slime-indentation-update-hooks) + +(defun slime-intern-indentation-spec (spec) + (cond ((consp spec) + (cons (slime-intern-indentation-spec (car spec)) + (slime-intern-indentation-spec (cdr spec)))) + ((stringp spec) + (intern spec)) + (t + spec))) + +;; FIXME: restore the old version without per-package +;; stuff. slime-indentation.el should be able tho disable the simple +;; version if needed. +(defun slime-handle-indentation-update (alist) + "Update Lisp indent information. + +ALIST is a list of (SYMBOL-NAME . INDENT-SPEC) of proposed indentation +settings for `common-lisp-indent-function'. The appropriate property +is setup, unless the user already set one explicitly." + (dolist (info alist) + (let ((symbol (intern (car info))) + (indent (slime-intern-indentation-spec (cl-second info))) + (packages (cl-third info))) + (if (and (boundp 'common-lisp-system-indentation) + (fboundp 'slime-update-system-indentation)) + ;; A table provided by slime-cl-indent.el. + (funcall #'slime-update-system-indentation symbol indent packages) + ;; Does the symbol have an indentation value that we set? + (when (equal (get symbol 'common-lisp-indent-function) + (get symbol 'slime-indent)) + (put symbol 'common-lisp-indent-function indent) + (put symbol 'slime-indent indent))) + (run-hook-with-args 'slime-indentation-update-hooks + symbol indent packages)))) + + +;;;; Contrib modules + +(defun slime-require (module) + (cl-pushnew module slime-required-modules) + (when (slime-connected-p) + (slime-load-contribs))) + +(defun slime-load-contribs () + (let ((needed (cl-remove-if (lambda (s) + (member (cl-subseq (symbol-name s) 1) + (mapcar #'downcase + (slime-lisp-modules)))) + slime-required-modules))) + (when needed + ;; No asynchronous request because with :SPAWN that could result + ;; in the attempt to load modules concurrently which may not be + ;; supported by the host Lisp. + (setf (slime-lisp-modules) + (slime-eval `(swank:swank-require ',needed)))))) + +(cl-defstruct slime-contrib + name + slime-dependencies + swank-dependencies + enable + disable + authors + license) + +(defun slime-contrib--enable-fun (name) + (intern (concat (symbol-name name) "-init"))) + +(defun slime-contrib--disable-fun (name) + (intern (concat (symbol-name name) "-unload"))) + +(defmacro define-slime-contrib (name _docstring &rest clauses) + (declare (indent 1)) + (cl-destructuring-bind (&key slime-dependencies + swank-dependencies + on-load + on-unload + authors + license) + (cl-loop for (key . value) in clauses append `(,key ,value)) + `(progn + ,@(mapcar (lambda (d) `(require ',d)) slime-dependencies) + (defun ,(slime-contrib--enable-fun name) () + (mapc #'funcall ',(mapcar + #'slime-contrib--enable-fun + slime-dependencies)) + (mapc #'slime-require ',swank-dependencies) + ,@on-load) + (defun ,(slime-contrib--disable-fun name) () + ,@on-unload + (mapc #'funcall ',(mapcar + #'slime-contrib--disable-fun + slime-dependencies))) + (put 'slime-contribs ',name + (make-slime-contrib + :name ',name :authors ',authors :license ',license + :slime-dependencies ',slime-dependencies + :swank-dependencies ',swank-dependencies + :enable ',(slime-contrib--enable-fun name) + :disable ',(slime-contrib--disable-fun name)))))) + +(defun slime-all-contribs () + (cl-loop for (nil val) on (symbol-plist 'slime-contribs) by #'cddr + when (slime-contrib-p val) + collect val)) + +(defun slime-contrib-all-dependencies (contrib) + "List all contribs recursively needed by CONTRIB, including self." + (cons contrib + (cl-mapcan #'slime-contrib-all-dependencies + (slime-contrib-slime-dependencies + (slime-find-contrib contrib))))) + +(defun slime-find-contrib (name) + (get 'slime-contribs name)) + +(defun slime-read-contrib-name () + (let ((names (cl-loop for c in (slime-all-contribs) collect + (symbol-name (slime-contrib-name c))))) + (intern (completing-read "Contrib: " names nil t)))) + +(defun slime-enable-contrib (name) + (interactive (list (slime-read-contrib-name))) + (let ((c (or (slime-find-contrib name) + (error "Unknown contrib: %S" name)))) + (funcall (slime-contrib-enable c)))) + +(defun slime-disable-contrib (name) + (interactive (list (slime-read-contrib-name))) + (let ((c (or (slime-find-contrib name) + (error "Unknown contrib: %S" name)))) + (funcall (slime-contrib-disable c)))) + + +;;;;; Pull-down menu + +(defvar slime-easy-menu + (let ((C '(slime-connected-p))) + `("SLIME" + [ "Edit Definition..." slime-edit-definition ,C ] + [ "Return From Definition" slime-pop-find-definition-stack ,C ] + [ "Complete Symbol" completion-at-point ,C ] + "--" + ("Evaluation" + [ "Eval Defun" slime-eval-defun ,C ] + [ "Eval Last Expression" slime-eval-last-expression ,C ] + [ "Eval And Pretty-Print" slime-pprint-eval-last-expression ,C ] + [ "Eval Region" slime-eval-region ,C ] + [ "Eval Region And Pretty-Print" slime-pprint-eval-region ,C ] + [ "Interactive Eval..." slime-interactive-eval ,C ] + [ "Edit Lisp Value..." slime-edit-value ,C ] + [ "Call Defun" slime-call-defun ,C ]) + ("Debugging" + [ "Macroexpand Once..." slime-macroexpand-1 ,C ] + [ "Macroexpand All..." slime-macroexpand-all ,C ] + [ "Create Trace Buffer" slime-redirect-trace-output ,C ] + [ "Toggle Trace..." slime-toggle-trace-fdefinition ,C ] + [ "Untrace All" slime-untrace-all ,C] + [ "Disassemble..." slime-disassemble-symbol ,C ] + [ "Inspect..." slime-inspect ,C ]) + ("Compilation" + [ "Compile Defun" slime-compile-defun ,C ] + [ "Compile/Load File" slime-compile-and-load-file ,C ] + [ "Compile File" slime-compile-file ,C ] + [ "Compile Region" slime-compile-region ,C ] + "--" + [ "Next Note" slime-next-note t ] + [ "Previous Note" slime-previous-note t ] + [ "Remove Notes" slime-remove-notes t ] + [ "List Notes" slime-list-compiler-notes ,C ]) + ("Cross Reference" + [ "Who Calls..." slime-who-calls ,C ] + [ "Who References... " slime-who-references ,C ] + [ "Who Sets..." slime-who-sets ,C ] + [ "Who Binds..." slime-who-binds ,C ] + [ "Who Macroexpands..." slime-who-macroexpands ,C ] + [ "Who Specializes..." slime-who-specializes ,C ] + [ "List Callers..." slime-list-callers ,C ] + [ "List Callees..." slime-list-callees ,C ] + [ "Next Location" slime-next-location t ]) + ("Editing" + [ "Check Parens" check-parens t] + [ "Update Indentation" slime-update-indentation ,C] + [ "Select Buffer" slime-selector t]) + ("Profiling" + [ "Toggle Profiling..." slime-toggle-profile-fdefinition ,C ] + [ "Profile Package" slime-profile-package ,C] + [ "Profile by Substring" slime-profile-by-substring ,C ] + [ "Unprofile All" slime-unprofile-all ,C ] + [ "Show Profiled" slime-profiled-functions ,C ] + "--" + [ "Report" slime-profile-report ,C ] + [ "Reset Counters" slime-profile-reset ,C ]) + ("Documentation" + [ "Describe Symbol..." slime-describe-symbol ,C ] + [ "Lookup Documentation..." slime-documentation-lookup t ] + [ "Apropos..." slime-apropos ,C ] + [ "Apropos all..." slime-apropos-all ,C ] + [ "Apropos Package..." slime-apropos-package ,C ] + [ "Hyperspec..." slime-hyperspec-lookup t ]) + "--" + [ "Interrupt Command" slime-interrupt ,C ] + [ "Abort Async. Command" slime-quit ,C ] + [ "Sync Package & Directory" slime-sync-package-and-default-directory ,C] + ))) + +(defvar slime-sldb-easy-menu + (let ((C '(slime-connected-p))) + `("SLDB" + [ "Next Frame" sldb-down t ] + [ "Previous Frame" sldb-up t ] + [ "Toggle Frame Details" sldb-toggle-details t ] + [ "Next Frame (Details)" sldb-details-down t ] + [ "Previous Frame (Details)" sldb-details-up t ] + "--" + [ "Eval Expression..." slime-interactive-eval ,C ] + [ "Eval in Frame..." sldb-eval-in-frame ,C ] + [ "Eval in Frame (pretty print)..." sldb-pprint-eval-in-frame ,C ] + [ "Inspect In Frame..." sldb-inspect-in-frame ,C ] + [ "Inspect Condition Object" sldb-inspect-condition ,C ] + "--" + [ "Restart Frame" sldb-restart-frame ,C ] + [ "Return from Frame..." sldb-return-from-frame ,C ] + ("Invoke Restart" + [ "Continue" sldb-continue ,C ] + [ "Abort" sldb-abort ,C ] + [ "Step" sldb-step ,C ] + [ "Step next" sldb-next ,C ] + [ "Step out" sldb-out ,C ] + ) + "--" + [ "Quit (throw)" sldb-quit ,C ] + [ "Break With Default Debugger" sldb-break-with-default-debugger ,C ]))) + +(easy-menu-define menubar-slime slime-mode-map "SLIME" slime-easy-menu) + +(defun slime-add-easy-menu () + (easy-menu-add slime-easy-menu 'slime-mode-map)) + +(add-hook 'slime-mode-hook 'slime-add-easy-menu) + +(defun slime-sldb-add-easy-menu () + (easy-menu-define menubar-slime-sldb + sldb-mode-map "SLDB" slime-sldb-easy-menu) + (easy-menu-add slime-sldb-easy-menu 'sldb-mode-map)) + +(add-hook 'sldb-mode-hook 'slime-sldb-add-easy-menu) + + +;;;; Cheat Sheet + +(defvar + slime-cheat-sheet-table + '((:title + "Editing lisp code" + :map slime-mode-map + :bindings ((slime-eval-defun "Evaluate current top level form") + (slime-compile-defun "Compile current top level form") + (slime-interactive-eval "Prompt for form and eval it") + (slime-compile-and-load-file "Compile and load current file") + (slime-sync-package-and-default-directory + "Synch default package and directory with current buffer") + (slime-next-note "Next compiler note") + (slime-previous-note "Previous compiler note") + (slime-remove-notes "Remove notes") + slime-documentation-lookup)) + (:title "Completion" + :map slime-mode-map + :bindings (slime-indent-and-complete-symbol + slime-fuzzy-complete-symbol)) + (:title + "Within SLDB buffers" + :map sldb-mode-map + :bindings ((sldb-default-action "Do 'whatever' with thing at point") + (sldb-toggle-details "Toggle frame details visualization") + (sldb-quit "Quit to REPL") + (sldb-abort "Invoke ABORT restart") + (sldb-continue "Invoke CONTINUE restart (if available)") + (sldb-show-source "Jump to frame's source code") + (sldb-eval-in-frame "Evaluate in frame at point") + (sldb-inspect-in-frame + "Evaluate in frame at point and inspect result"))) + (:title + "Within the Inspector" + :map slime-inspector-mode-map + :bindings ((slime-inspector-next-inspectable-object + "Jump to next inspectable object") + (slime-inspector-operate-on-point + "Inspect object or execute action at point") + (slime-inspector-reinspect "Reinspect current object") + (slime-inspector-pop "Return to previous object") + ;;(slime-inspector-copy-down "Send object at point to REPL") + (slime-inspector-toggle-verbose "Toggle verbose mode") + (slime-inspector-quit "Quit"))) + (:title + "Finding Definitions" + :map slime-mode-map + :bindings (slime-edit-definition + slime-pop-find-definition-stack)))) + +(defun slime-cheat-sheet () + (interactive) + (switch-to-buffer-other-frame + (get-buffer-create (slime-buffer-name :cheat-sheet))) + (setq buffer-read-only nil) + (delete-region (point-min) (point-max)) + (goto-char (point-min)) + (insert + "SLIME: The Superior Lisp Interaction Mode for Emacs (minor-mode).\n\n") + (dolist (mode slime-cheat-sheet-table) + (let ((title (cl-getf mode :title)) + (mode-map (cl-getf mode :map)) + (mode-keys (cl-getf mode :bindings))) + (insert title) + (insert ":\n") + (insert (make-string (1+ (length title)) ?-)) + (insert "\n") + (let ((keys '()) + (descriptions '())) + (dolist (func mode-keys) + ;; func is eithor the function name or a list (NAME DESCRIPTION) + (push (if (symbolp func) + (prin1-to-string func) + (cl-second func)) + descriptions) + (let ((all-bindings (where-is-internal (if (symbolp func) + func + (cl-first func)) + (symbol-value mode-map))) + (key-bindings '())) + (dolist (binding all-bindings) + (when (and (vectorp binding) + (integerp (aref binding 0))) + (push binding key-bindings))) + (push (mapconcat 'key-description key-bindings " or ") keys))) + (cl-loop with desc-length = (apply 'max (mapcar 'length descriptions)) + for key in (nreverse keys) + for desc in (nreverse descriptions) + do (insert desc) + do (insert (make-string (- desc-length (length desc)) ? )) + do (insert " => ") + do (insert (if (string= "" key) + "<not on any key>" + key)) + do (insert "\n") + finally do (insert "\n"))))) + (setq buffer-read-only t) + (goto-char (point-min))) + + +;;;; Utilities (no not Paul Graham style) + +;; XXX: unused function +(defun slime-intersperse (element list) + "Intersperse ELEMENT between each element of LIST." + (if (null list) + '() + (cons (car list) + (cl-mapcan (lambda (x) (list element x)) (cdr list))))) + +;;; FIXME: this looks almost slime `slime-alistify', perhaps the two +;;; functions can be merged. +(defun slime-group-similar (similar-p list) + "Return the list of lists of 'similar' adjacent elements of LIST. +The function SIMILAR-P is used to test for similarity. +The order of the input list is preserved." + (if (null list) + nil + (let ((accumulator (list (list (car list))))) + (dolist (x (cdr list)) + (if (funcall similar-p x (caar accumulator)) + (push x (car accumulator)) + (push (list x) accumulator))) + (reverse (mapcar #'reverse accumulator))))) + +(defun slime-alistify (list key test) + "Partition the elements of LIST into an alist. +KEY extracts the key from an element and TEST is used to compare +keys." + (let ((alist '())) + (dolist (e list) + (let* ((k (funcall key e)) + (probe (cl-assoc k alist :test test))) + (if probe + (push e (cdr probe)) + (push (cons k (list e)) alist)))) + ;; Put them back in order. + (cl-loop for (key . value) in (reverse alist) + collect (cons key (reverse value))))) + +;;;;; Misc. + +(defun slime-length= (seq n) + "Return (= (length SEQ) N)." + (cl-etypecase seq + (list + (cond ((zerop n) (null seq)) + ((let ((tail (nthcdr (1- n) seq))) + (and tail (null (cdr tail))))))) + (sequence + (= (length seq) n)))) + +(defun slime-length> (seq n) + "Return (> (length SEQ) N)." + (cl-etypecase seq + (list (nthcdr n seq)) + (sequence (> (length seq) n)))) + +(defun slime-trim-whitespace (str) + (let ((start (cl-position-if-not (lambda (x) + (memq x '(?\t ?\n ?\s ?\r))) + str)) + + (end (cl-position-if-not (lambda (x) + (memq x '(?\t ?\n ?\s ?\r))) + str + :from-end t))) + (if start + (substring str start (1+ end)) + ""))) + +;;;;; Buffer related + +(defun slime-buffer-narrowed-p (&optional buffer) + "Returns T if BUFFER (or the current buffer respectively) is narrowed." + (with-current-buffer (or buffer (current-buffer)) + (let ((beg (point-min)) + (end (point-max)) + (total (buffer-size))) + (or (/= beg 1) (/= end (1+ total)))))) + +(defun slime-column-max () + (save-excursion + (goto-char (point-min)) + (cl-loop for column = (prog2 (end-of-line) (current-column) (forward-line)) + until (= (point) (point-max)) + maximizing column))) + +;;;;; CL symbols vs. Elisp symbols. + +(defun slime-cl-symbol-name (symbol) + (let ((n (if (stringp symbol) symbol (symbol-name symbol)))) + (if (string-match ":\\([^:]*\\)$" n) + (let ((symbol-part (match-string 1 n))) + (if (string-match "^|\\(.*\\)|$" symbol-part) + (match-string 1 symbol-part) + symbol-part)) + n))) + +(defun slime-cl-symbol-package (symbol &optional default) + (let ((n (if (stringp symbol) symbol (symbol-name symbol)))) + (if (string-match "^\\([^:]*\\):" n) + (match-string 1 n) + default))) + +(defun slime-qualify-cl-symbol-name (symbol-or-name) + "Return a package-qualified string for SYMBOL-OR-NAME. +If SYMBOL-OR-NAME doesn't already have a package prefix the +current package is used." + (let ((s (if (stringp symbol-or-name) + symbol-or-name + (symbol-name symbol-or-name)))) + (if (slime-cl-symbol-package s) + s + (format "%s::%s" + (let* ((package (slime-current-package))) + ;; package is a string like ":cl-user" + ;; or "CL-USER", or "\"CL-USER\"". + (if package + (slime-pretty-package-name package) + "CL-USER")) + (slime-cl-symbol-name s))))) + +;;;;; Moving, CL idiosyncracies aware (reader conditionals &c.) + +(defmacro slime-point-moves-p (&rest body) + "Execute BODY and return true if the current buffer's point moved." + (declare (indent 0)) + (let ((pointvar (cl-gensym "point-"))) + `(let ((,pointvar (point))) + (save-current-buffer ,@body) + (/= ,pointvar (point))))) + +(defun slime-forward-sexp (&optional count) + "Like `forward-sexp', but understands reader-conditionals (#- and #+), +and skips comments." + (dotimes (_i (or count 1)) + (slime-forward-cruft) + (forward-sexp))) + +(defconst slime-reader-conditionals-regexp + ;; #!+, #!- are SBCL specific reader-conditional syntax. + ;; We need this for the source files of SBCL itself. + (regexp-opt '("#+" "#-" "#!+" "#!-"))) + +(defun slime-forward-reader-conditional () + "Move past any reader conditional (#+ or #-) at point." + (when (looking-at slime-reader-conditionals-regexp) + (goto-char (match-end 0)) + (let* ((plus-conditional-p (eq (char-before) ?+)) + (result (slime-eval-feature-expression + (condition-case e + (read (current-buffer)) + (invalid-read-syntax + (signal 'slime-unknown-feature-expression (cdr e))))))) + (unless (if plus-conditional-p result (not result)) + ;; skip this sexp + (slime-forward-sexp))))) + +(defun slime-forward-cruft () + "Move forward over whitespace, comments, reader conditionals." + (while (slime-point-moves-p (skip-chars-forward " \t\n") + (forward-comment (buffer-size)) + (inline (slime-forward-reader-conditional))))) + +(defun slime-keywordify (symbol) + "Make a keyword out of the symbol SYMBOL." + (let ((name (downcase (symbol-name symbol)))) + (intern (if (eq ?: (aref name 0)) + name + (concat ":" name))))) + +(put 'slime-incorrect-feature-expression + 'error-conditions '(slime-incorrect-feature-expression error)) + +(put 'slime-unknown-feature-expression + 'error-conditions '(slime-unknown-feature-expression + slime-incorrect-feature-expression + error)) + +;; FIXME: let it crash +;; FIXME: the length=1 constraint is bogus +(defun slime-eval-feature-expression (e) + "Interpret a reader conditional expression." + (cond ((symbolp e) + (memq (slime-keywordify e) (slime-lisp-features))) + ((and (consp e) (symbolp (car e))) + (funcall (let ((head (slime-keywordify (car e)))) + (cl-case head + (:and #'cl-every) + (:or #'cl-some) + (:not + (lexical-let ((feature-expression e)) + (lambda (f l) + (cond + ((slime-length= l 0) t) + ((slime-length= l 1) (not (apply f l))) + (t (signal 'slime-incorrect-feature-expression + feature-expression)))))) + (t (signal 'slime-unknown-feature-expression head)))) + #'slime-eval-feature-expression + (cdr e))) + (t (signal 'slime-incorrect-feature-expression e)))) + +;;;;; Extracting Lisp forms from the buffer or user + +(defun slime-defun-at-point () + "Return the text of the defun at point." + (apply #'buffer-substring-no-properties + (slime-region-for-defun-at-point))) + +(defun slime-region-for-defun-at-point () + "Return the start and end position of defun at point." + (save-excursion + (save-match-data + (end-of-defun) + (let ((end (point))) + (beginning-of-defun) + (list (point) end))))) + +(defun slime-beginning-of-symbol () + "Move to the beginning of the CL-style symbol at point." + (while (re-search-backward "\\(\\sw\\|\\s_\\|\\s\\.\\|\\s\\\\|[#@|]\\)\\=" + (when (> (point) 2000) (- (point) 2000)) + t)) + (re-search-forward "\\=#[-+.<|]" nil t) + (when (and (looking-at "@") (eq (char-before) ?\,)) + (forward-char))) + +(defun slime-end-of-symbol () + "Move to the end of the CL-style symbol at point." + (re-search-forward "\\=\\(\\sw\\|\\s_\\|\\s\\.\\|#:\\|[@|]\\)*")) + +(put 'slime-symbol 'end-op 'slime-end-of-symbol) +(put 'slime-symbol 'beginning-op 'slime-beginning-of-symbol) + +(defun slime-symbol-start-pos () + "Return the starting position of the symbol under point. +The result is unspecified if there isn't a symbol under the point." + (save-excursion (slime-beginning-of-symbol) (point))) + +(defun slime-symbol-end-pos () + (save-excursion (slime-end-of-symbol) (point))) + +(defun slime-bounds-of-symbol-at-point () + "Return the bounds of the symbol around point. +The returned bounds are either nil or non-empty." + (let ((bounds (bounds-of-thing-at-point 'slime-symbol))) + (if (and bounds + (< (car bounds) + (cdr bounds))) + bounds))) + +(defun slime-symbol-at-point () + "Return the name of the symbol at point, otherwise nil." + ;; (thing-at-point 'symbol) returns "" in empty buffers + (let ((bounds (slime-bounds-of-symbol-at-point))) + (if bounds + (buffer-substring-no-properties (car bounds) + (cdr bounds))))) + +(defun slime-bounds-of-sexp-at-point () + "Return the bounds sexp at point as a pair (or nil)." + (or (slime-bounds-of-symbol-at-point) + (and (equal (char-after) ?\() + (member (char-before) '(?\' ?\, ?\@)) + ;; hide stuff before ( to avoid quirks with '( etc. + (save-restriction + (narrow-to-region (point) (point-max)) + (bounds-of-thing-at-point 'sexp))) + (bounds-of-thing-at-point 'sexp))) + +(defun slime-sexp-at-point () + "Return the sexp at point as a string, otherwise nil." + (let ((bounds (slime-bounds-of-sexp-at-point))) + (if bounds + (buffer-substring-no-properties (car bounds) + (cdr bounds))))) + +(defun slime-sexp-at-point-or-error () + "Return the sexp at point as a string, othwise signal an error." + (or (slime-sexp-at-point) (user-error "No expression at point"))) + +(defun slime-string-at-point () + "Returns the string at point as a string, otherwise nil." + (let ((sexp (slime-sexp-at-point))) + (if (and sexp + (eql (char-syntax (aref sexp 0)) ?\")) + sexp + nil))) + +(defun slime-string-at-point-or-error () + "Return the sexp at point as a string, othwise signal an error." + (or (slime-string-at-point) (error "No string at point."))) + +(defun slime-input-complete-p (start end) + "Return t if the region from START to END contains a complete sexp." + (save-excursion + (goto-char start) + (cond ((looking-at "\\s *['`#]?[(\"]") + (ignore-errors + (save-restriction + (narrow-to-region start end) + ;; Keep stepping over blanks and sexps until the end of + ;; buffer is reached or an error occurs. Tolerate extra + ;; close parens. + (cl-loop do (skip-chars-forward " \t\r\n)") + until (eobp) + do (forward-sexp)) + t))) + (t t)))) + + +;;;; slime.el in pretty colors + +(cl-loop for sym in (list 'slime-def-connection-var + 'slime-define-channel-type + 'slime-define-channel-method + 'define-slime-contrib + 'slime-defun-if-undefined + 'slime-defmacro-if-undefined) + for regexp = (format "(\\(%S\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" + sym) + do (font-lock-add-keywords + 'emacs-lisp-mode + `((,regexp (1 font-lock-keyword-face) + (2 font-lock-variable-name-face))))) + +;;;; Finishing up + +(eval-when-compile + (require 'bytecomp)) + +(defun slime--byte-compile (symbol) + (require 'bytecomp) ;; tricky interaction between autoload and let. + (let ((byte-compile-warnings '())) + (byte-compile symbol))) + +(defun slime--compile-hotspots () + (mapc (lambda (sym) + (cond ((fboundp sym) + (unless (byte-code-function-p (symbol-function sym)) + (slime--byte-compile sym))) + (t (error "%S is not fbound" sym)))) + '(slime-alistify + slime-log-event + slime-events-buffer + slime-process-available-input + slime-dispatch-event + slime-net-filter + slime-net-have-input-p + slime-net-decode-length + slime-net-read + slime-print-apropos + slime-insert-propertized + slime-beginning-of-symbol + slime-end-of-symbol + slime-eval-feature-expression + slime-forward-sexp + slime-forward-cruft + slime-forward-reader-conditional))) + +(slime--compile-hotspots) + +(add-to-list 'load-path (expand-file-name "contrib" slime-path)) + +(run-hooks 'slime-load-hook) +(provide 'slime) + +;; Local Variables: +;; outline-regexp: ";;;;+" +;; indent-tabs-mode: nil +;; coding: latin-1-unix +;; End: +;;; slime.el ends here diff --git a/vim/bundle/slimv/slime/start-swank.lisp b/vim/bundle/slimv/slime/start-swank.lisp new file mode 100644 index 0000000..77bd3aa --- /dev/null +++ b/vim/bundle/slimv/slime/start-swank.lisp @@ -0,0 +1,39 @@ +;;; This file is intended to be loaded by an implementation to +;;; get a running swank server +;;; e.g. sbcl --load start-swank.lisp +;;; +;;; Default port is 4005 + +;;; For additional swank-side configurations see +;;; 6.2 section of the Slime user manual. +;;; +;;; Modified for Slimv: +;;; - don't close connection +;;; - pass swank port in environment variable + +(load (merge-pathnames "swank-loader.lisp" *load-truename*)) + +(swank-loader:init + :delete nil ; delete any existing SWANK packages + :reload nil ; reload SWANK, even if the SWANK package already exists + :load-contribs nil) ; load all contribs + +(defun my-getenv (name &optional default) + #+CMU + (let ((x (assoc name ext:*environment-list* + :test #'string=))) + (if x (cdr x) default)) + #-CMU + (or + #+Allegro (sys:getenv name) + #+CLISP (ext:getenv name) + #+ECL (si:getenv name) + #+SBCL (sb-unix::posix-getenv name) + #+LISPWORKS (lispworks:environment-variable name) + #+CCL (ccl::getenv name) + default)) + +(swank:create-server :port (parse-integer (my-getenv "SWANK_PORT" "4005")) + ;; if non-nil the connection won't be closed + ;; after connecting + :dont-close t) diff --git a/vim/bundle/slimv/slime/swank-loader.lisp b/vim/bundle/slimv/slime/swank-loader.lisp new file mode 100644 index 0000000..7bb81da --- /dev/null +++ b/vim/bundle/slimv/slime/swank-loader.lisp @@ -0,0 +1,366 @@ +;;;; -*- indent-tabs-mode: nil -*- +;;; +;;; swank-loader.lisp --- Compile and load the Slime backend. +;;; +;;; Created 2003, James Bielman <jamesjb@jamesjb.com> +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +;; If you want customize the source- or fasl-directory you can set +;; swank-loader:*source-directory* resp. swank-loader:*fasl-directory* +;; before loading this files. +;; E.g.: +;; +;; (load ".../swank-loader.lisp") +;; (setq swank-loader::*fasl-directory* "/tmp/fasl/") +;; (swank-loader:init) + +(cl:defpackage :swank-loader + (:use :cl) + (:export :init + :dump-image + :list-fasls + :*source-directory* + :*fasl-directory*)) + +(cl:in-package :swank-loader) + +(defvar *source-directory* + (make-pathname :name nil :type nil + :defaults (or *load-pathname* *default-pathname-defaults*)) + "The directory where to look for the source.") + +(defparameter *sysdep-files* + #+cmu '((swank source-path-parser) (swank source-file-cache) (swank cmucl) + (swank gray)) + #+scl '((swank source-path-parser) (swank source-file-cache) (swank scl) + (swank gray)) + #+sbcl '((swank source-path-parser) (swank source-file-cache) (swank sbcl) + (swank gray)) + #+clozure '(metering (swank ccl) (swank gray)) + #+lispworks '((swank lispworks) (swank gray)) + #+allegro '((swank allegro) (swank gray)) + #+clisp '(xref metering (swank clisp) (swank gray)) + #+armedbear '((swank abcl)) + #+cormanlisp '((swank corman) (swank gray)) + #+ecl '((swank ecl) (swank gray)) + #+clasp '((swank clasp) (swank gray)) + #+mkcl '((swank mkcl) (swank gray)) + ) + +(defparameter *implementation-features* + '(:allegro :lispworks :sbcl :clozure :cmu :clisp :ccl :corman :cormanlisp + :armedbear :gcl :ecl :scl :mkcl :clasp)) + +(defparameter *os-features* + '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :hpux + :unix)) + +(defparameter *architecture-features* + '(:powerpc :ppc :x86 :x86-64 :x86_64 :amd64 :i686 :i586 :i486 :pc386 :iapx386 + :sparc64 :sparc :hppa64 :hppa :arm :armv5l :armv6l :armv7l :arm64 + :pentium3 :pentium4 + :mips :mipsel + :java-1.4 :java-1.5 :java-1.6 :java-1.7)) + +(defun q (s) (read-from-string s)) + +#+ecl +(defun ecl-version-string () + (format nil "~A~@[-~A~]" + (lisp-implementation-version) + (when (find-symbol "LISP-IMPLEMENTATION-VCS-ID" :ext) + (let ((vcs-id (funcall (q "ext:lisp-implementation-vcs-id")))) + (when (>= (length vcs-id) 8) + (subseq vcs-id 0 8)))))) + +#+clasp +(defun clasp-version-string () + (format nil "~A~@[-~A~]" + (lisp-implementation-version) + (core:lisp-implementation-id))) + +(defun lisp-version-string () + #+(or clozure cmu) (substitute-if #\_ (lambda (x) (find x " /")) + (lisp-implementation-version)) + #+(or cormanlisp scl mkcl) (lisp-implementation-version) + #+sbcl (format nil "~a~:[~;-no-threads~]" + (lisp-implementation-version) + #+sb-thread nil + #-sb-thread t) + #+lispworks (lisp-implementation-version) + #+allegro (format nil "~@{~a~}" + excl::*common-lisp-version-number* + (if (eq 'h 'H) "A" "M") ; ANSI vs MoDeRn + (if (member :smp *features*) "s" "") + (if (member :64bit *features*) "-64bit" "") + (excl:ics-target-case + (:-ics "") + (:+ics "-ics"))) + #+clisp (let ((s (lisp-implementation-version))) + (subseq s 0 (position #\space s))) + #+armedbear (lisp-implementation-version) + #+ecl (ecl-version-string) + #+clasp (clasp-version-string)) + +(defun unique-dir-name () + "Return a name that can be used as a directory name that is +unique to a Lisp implementation, Lisp implementation version, +operating system, and hardware architecture." + (flet ((first-of (features) + (loop for f in features + when (find f *features*) return it)) + (maybe-warn (value fstring &rest args) + (cond (value) + (t (apply #'warn fstring args) + "unknown")))) + (let ((lisp (maybe-warn (first-of *implementation-features*) + "No implementation feature found in ~a." + *implementation-features*)) + (os (maybe-warn (first-of *os-features*) + "No os feature found in ~a." *os-features*)) + (arch (maybe-warn (first-of *architecture-features*) + "No architecture feature found in ~a." + *architecture-features*)) + (version (maybe-warn (lisp-version-string) + "Don't know how to get Lisp ~ + implementation version."))) + (format nil "~(~@{~a~^-~}~)" lisp version os arch)))) + +(defun file-newer-p (new-file old-file) + "Returns true if NEW-FILE is newer than OLD-FILE." + (> (file-write-date new-file) (file-write-date old-file))) + +(defun string-starts-with (string prefix) + (string-equal string prefix :end1 (min (length string) (length prefix)))) + +(defun slime-version-string () + "Return a string identifying the SLIME version. +Return nil if nothing appropriate is available." + (with-open-file (s (merge-pathnames "slime.el" *source-directory*) + :if-does-not-exist nil) + (loop with prefix = ";; Version: " + for line = (read-line s nil :eof) + until (eq line :eof) + when (string-starts-with line prefix) + return (subseq line (length prefix))))) + +(defun default-fasl-dir () + (merge-pathnames + (make-pathname + :directory `(:relative ".slime" "fasl" + ,@(if (slime-version-string) (list (slime-version-string))) + ,(unique-dir-name))) + (user-homedir-pathname))) + +(defvar *fasl-directory* (default-fasl-dir) + "The directory where fasl files should be placed.") + +(defun binary-pathname (src-pathname binary-dir) + "Return the pathname where SRC-PATHNAME's binary should be compiled." + (let ((cfp (compile-file-pathname src-pathname))) + (merge-pathnames (make-pathname :name (pathname-name cfp) + :type (pathname-type cfp)) + binary-dir))) + +(defun handle-swank-load-error (condition context pathname) + (fresh-line *error-output*) + (pprint-logical-block (*error-output* () :per-line-prefix ";; ") + (format *error-output* + "~%Error ~A ~A:~% ~A~%" + context pathname condition))) + +(defun compile-files (files fasl-dir load quiet) + "Compile each file in FILES if the source is newer than its +corresponding binary, or the file preceding it was recompiled. +If LOAD is true, load the fasl file." + (let ((needs-recompile nil) + (state :unknown)) + (dolist (src files) + (let ((dest (binary-pathname src fasl-dir))) + (handler-bind + ((error (lambda (c) + (ecase state + (:compile (handle-swank-load-error c "compiling" src)) + (:load (handle-swank-load-error c "loading" dest)) + (:unknown (handle-swank-load-error c "???ing" src)))))) + (when (or needs-recompile + (not (probe-file dest)) + (file-newer-p src dest)) + (ensure-directories-exist dest) + ;; need to recompile SRC, so we'll need to recompile + ;; everything after this too. + (setf needs-recompile t + state :compile) + (or (compile-file src :output-file dest :print nil + :verbose (not quiet)) + ;; An implementation may not necessarily signal a + ;; condition itself when COMPILE-FILE fails (e.g. ECL) + (error "COMPILE-FILE returned NIL."))) + (when load + (setf state :load) + (load dest :verbose (not quiet)))))))) + +#+cormanlisp +(defun compile-files (files fasl-dir load quiet) + "Corman Lisp has trouble with compiled files." + (declare (ignore fasl-dir)) + (when load + (dolist (file files) + (load file :verbose (not quiet) + (force-output))))) + +(defun load-user-init-file () + "Load the user init file, return NIL if it does not exist." + (load (merge-pathnames (user-homedir-pathname) + (make-pathname :name ".swank" :type "lisp")) + :if-does-not-exist nil)) + +(defun load-site-init-file (dir) + (load (make-pathname :name "site-init" :type "lisp" + :defaults dir) + :if-does-not-exist nil)) + +(defun src-files (names src-dir) + (mapcar (lambda (name) + (multiple-value-bind (dirs name) + (etypecase name + (symbol (values '() name)) + (cons (values (butlast name) (car (last name))))) + (make-pathname + :directory (append (or (pathname-directory src-dir) + '(:relative)) + (mapcar #'string-downcase dirs)) + :name (string-downcase name) + :type "lisp" + :defaults src-dir))) + names)) + +(defvar *swank-files* + `(packages + (swank backend) ,@*sysdep-files* (swank match) (swank rpc) + swank)) + +(defvar *contribs* + '(swank-util swank-repl + swank-c-p-c swank-arglists swank-fuzzy + swank-fancy-inspector + swank-presentations swank-presentation-streams + #+(or asdf2 asdf3 sbcl ecl) swank-asdf + swank-package-fu + swank-hyperdoc + #+sbcl swank-sbcl-exts + swank-mrepl + swank-trace-dialog + swank-macrostep + swank-quicklisp) + "List of names for contrib modules.") + +(defun append-dir (absolute name) + (merge-pathnames + (make-pathname :directory `(:relative ,name) :defaults absolute) + absolute)) + +(defun contrib-dir (base-dir) + (append-dir base-dir "contrib")) + +(defun load-swank (&key (src-dir *source-directory*) + (fasl-dir *fasl-directory*) + quiet) + (with-compilation-unit () + (compile-files (src-files *swank-files* src-dir) fasl-dir t quiet)) + (funcall (q "swank::before-init") + (slime-version-string) + (list (contrib-dir fasl-dir) + (contrib-dir src-dir)))) + +(defun delete-stale-contrib-fasl-files (swank-files contrib-files fasl-dir) + (let ((newest (reduce #'max (mapcar #'file-write-date swank-files)))) + (dolist (src contrib-files) + (let ((fasl (binary-pathname src fasl-dir))) + (when (and (probe-file fasl) + (<= (file-write-date fasl) newest)) + (delete-file fasl)))))) + +(defun compile-contribs (&key (src-dir (contrib-dir *source-directory*)) + (fasl-dir (contrib-dir *fasl-directory*)) + (swank-src-dir *source-directory*) + load quiet) + (let* ((swank-src-files (src-files *swank-files* swank-src-dir)) + (contrib-src-files (src-files *contribs* src-dir))) + (delete-stale-contrib-fasl-files swank-src-files contrib-src-files + fasl-dir) + (compile-files contrib-src-files fasl-dir load quiet))) + +(defun loadup () + (load-swank) + (compile-contribs :load t)) + +(defun setup () + (load-site-init-file *source-directory*) + (load-user-init-file) + (when (#-clisp probe-file + #+clisp ext:probe-directory + (contrib-dir *source-directory*)) + (eval `(pushnew 'compile-contribs ,(q "swank::*after-init-hook*")))) + (funcall (q "swank::init"))) + +(defun list-swank-packages () + (remove-if-not (lambda (package) + (let ((name (package-name package))) + (and (string-not-equal name "swank-loader") + (string-starts-with name "swank")))) + (list-all-packages))) + +(defun delete-packages (packages) + (dolist (package packages) + (flet ((handle-package-error (c) + (let ((pkgs (set-difference (package-used-by-list package) + packages))) + (when pkgs + (warn "deleting ~a which is used by ~{~a~^, ~}." + package pkgs)) + (continue c)))) + (handler-bind ((package-error #'handle-package-error)) + (delete-package package))))) + +(defun init (&key delete reload load-contribs (setup t) + (quiet (not *load-verbose*))) + "Load SWANK and initialize some global variables. +If DELETE is true, delete any existing SWANK packages. +If RELOAD is true, reload SWANK, even if the SWANK package already exists. +If LOAD-CONTRIBS is true, load all contribs +If SETUP is true, load user init files and initialize some +global variabes in SWANK." + (when (and delete (find-package :swank)) + (delete-packages (list-swank-packages))) + (cond ((or (not (find-package :swank)) reload) + (load-swank :quiet quiet)) + (t + (warn "Not reloading SWANK. Package already exists."))) + (when load-contribs + (compile-contribs :load t :quiet quiet)) + (when setup + (setup))) + +(defun dump-image (filename) + (init :setup nil) + (funcall (q "swank/backend:save-image") filename)) + +(defun list-fasls (&key (include-contribs t) (compile t) + (quiet (not *compile-verbose*))) + "List up SWANK's fasls along with their dependencies." + (flet ((collect-fasls (files fasl-dir) + (when compile + (compile-files files fasl-dir nil quiet)) + (loop for src in files + when (probe-file (binary-pathname src fasl-dir)) + collect it))) + (append (collect-fasls (src-files *swank-files* *source-directory*) + *fasl-directory*) + (when include-contribs + (collect-fasls (src-files *contribs* + (contrib-dir *source-directory*)) + (contrib-dir *fasl-directory*)))))) diff --git a/vim/bundle/slimv/slime/swank.asd b/vim/bundle/slimv/slime/swank.asd new file mode 100644 index 0000000..d9a7627 --- /dev/null +++ b/vim/bundle/slimv/slime/swank.asd @@ -0,0 +1,37 @@ +;;; -*- lisp -*- + +;; ASDF system definition for loading the Swank server independently +;; of Emacs. +;; +;; This is only useful if you want to start a Swank server in a Lisp +;; processes that doesn't run under Emacs. Lisp processes created by +;; `M-x slime' automatically start the server. + +;; Usage: +;; +;; (require :swank) +;; (swank:create-swank-server PORT) => ACTUAL-PORT +;; +;; (PORT can be zero to mean "any available port".) +;; Then the Swank server is running on localhost:ACTUAL-PORT. You can +;; use `M-x slime-connect' to connect Emacs to it. +;; +;; This code has been placed in the Public Domain. All warranties +;; are disclaimed. + +(defpackage :swank-loader + (:use :cl)) + +(in-package :swank-loader) + +(defclass swank-loader-file (asdf:cl-source-file) ()) + +;;;; after loading run init + +(defmethod asdf:perform ((o asdf:load-op) (f swank-loader-file)) + (load (asdf::component-pathname f)) + (funcall (read-from-string "swank-loader::init") :reload t)) + +(asdf:defsystem :swank + :default-component-class swank-loader-file + :components ((:file "swank-loader"))) diff --git a/vim/bundle/slimv/slime/swank.lisp b/vim/bundle/slimv/slime/swank.lisp new file mode 100644 index 0000000..909bd19 --- /dev/null +++ b/vim/bundle/slimv/slime/swank.lisp @@ -0,0 +1,3743 @@ +;;;; swank.lisp --- Server for SLIME commands. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; +;;; This file defines the "Swank" TCP server for Emacs to talk to. The +;;; code in this file is purely portable Common Lisp. We do require a +;;; smattering of non-portable functions in order to write the server, +;;; so we have defined them in `swank/backend.lisp' and implemented +;;; them separately for each Lisp implementation. These extensions are +;;; available to us here via the `SWANK/BACKEND' package. + +(in-package :swank) +;;;; Top-level variables, constants, macros + +(defconstant cl-package (find-package :cl) + "The COMMON-LISP package.") + +(defconstant keyword-package (find-package :keyword) + "The KEYWORD package.") + +(defconstant default-server-port 4005 + "The default TCP port for the server (when started manually).") + +(defvar *swank-debug-p* t + "When true, print extra debugging information.") + +(defvar *backtrace-pprint-dispatch-table* + (let ((table (copy-pprint-dispatch nil))) + (flet ((print-string (stream string) + (cond (*print-escape* + (escape-string string stream + :map '((#\" . "\\\"") + (#\\ . "\\\\") + (#\newline . "\\n") + (#\return . "\\r")))) + (t (write-string string stream))))) + (set-pprint-dispatch 'string #'print-string 0 table) + table))) + +(defvar *backtrace-printer-bindings* + `((*print-pretty* . t) + (*print-readably* . nil) + (*print-level* . 4) + (*print-length* . 6) + (*print-lines* . 1) + (*print-right-margin* . 200) + (*print-pprint-dispatch* . ,*backtrace-pprint-dispatch-table*)) + "Pretter settings for printing backtraces.") + +(defvar *default-worker-thread-bindings* '() + "An alist to initialize dynamic variables in worker threads. +The list has the form ((VAR . VALUE) ...). Each variable VAR will be +bound to the corresponding VALUE.") + +(defun call-with-bindings (alist fun) + "Call FUN with variables bound according to ALIST. +ALIST is a list of the form ((VAR . VAL) ...)." + (if (null alist) + (funcall fun) + (let* ((rlist (reverse alist)) + (vars (mapcar #'car rlist)) + (vals (mapcar #'cdr rlist))) + (progv vars vals + (funcall fun))))) + +(defmacro with-bindings (alist &body body) + "See `call-with-bindings'." + `(call-with-bindings ,alist (lambda () ,@body))) + +;;; The `DEFSLIMEFUN' macro defines a function that Emacs can call via +;;; RPC. + +(defmacro defslimefun (name arglist &body rest) + "A DEFUN for functions that Emacs can call by RPC." + `(progn + (defun ,name ,arglist ,@rest) + ;; see <http://www.franz.com/support/documentation/6.2/\ + ;; doc/pages/variables/compiler/\ + ;; s_cltl1-compile-file-toplevel-compatibility-p_s.htm> + (eval-when (:compile-toplevel :load-toplevel :execute) + (export ',name (symbol-package ',name))))) + +(defun missing-arg () + "A function that the compiler knows will never to return a value. +You can use (MISSING-ARG) as the initform for defstruct slots that +must always be supplied. This way the :TYPE slot option need not +include some arbitrary initial value like NIL." + (error "A required &KEY or &OPTIONAL argument was not supplied.")) + + +;;;; Hooks +;;; +;;; We use Emacs-like `add-hook' and `run-hook' utilities to support +;;; simple indirection. The interface is more CLish than the Emacs +;;; Lisp one. + +(defmacro add-hook (place function) + "Add FUNCTION to the list of values on PLACE." + `(pushnew ,function ,place)) + +(defun run-hook (functions &rest arguments) + "Call each of FUNCTIONS with ARGUMENTS." + (dolist (function functions) + (apply function arguments))) + +(defvar *new-connection-hook* '() + "This hook is run each time a connection is established. +The connection structure is given as the argument. +Backend code should treat the connection structure as opaque.") + +(defvar *connection-closed-hook* '() + "This hook is run when a connection is closed. +The connection as passed as an argument. +Backend code should treat the connection structure as opaque.") + +(defvar *pre-reply-hook* '() + "Hook run (without arguments) immediately before replying to an RPC.") + +(defvar *after-init-hook* '() + "Hook run after user init files are loaded.") + + +;;;; Connections +;;; +;;; Connection structures represent the network connections between +;;; Emacs and Lisp. Each has a socket stream, a set of user I/O +;;; streams that redirect to Emacs, and optionally a second socket +;;; used solely to pipe user-output to Emacs (an optimization). This +;;; is also the place where we keep everything that needs to be +;;; freed/closed/killed when we disconnect. + +(defstruct (connection + (:constructor %make-connection) + (:conc-name connection.) + (:print-function print-connection)) + ;; The listening socket. (usually closed) + (socket (missing-arg) :type t :read-only t) + ;; Character I/O stream of socket connection. Read-only to avoid + ;; race conditions during initialization. + (socket-io (missing-arg) :type stream :read-only t) + ;; Optional dedicated output socket (backending `user-output' slot). + ;; Has a slot so that it can be closed with the connection. + (dedicated-output nil :type (or stream null)) + ;; Streams that can be used for user interaction, with requests + ;; redirected to Emacs. + (user-input nil :type (or stream null)) + (user-output nil :type (or stream null)) + (user-io nil :type (or stream null)) + ;; Bindings used for this connection (usually streams) + (env '() :type list) + ;; A stream that we use for *trace-output*; if nil, we user user-output. + (trace-output nil :type (or stream null)) + ;; A stream where we send REPL results. + (repl-results nil :type (or stream null)) + ;; Cache of macro-indentation information that has been sent to Emacs. + ;; This is used for preparing deltas to update Emacs's knowledge. + ;; Maps: symbol -> indentation-specification + (indentation-cache (make-hash-table :test 'eq) :type hash-table) + ;; The list of packages represented in the cache: + (indentation-cache-packages '()) + ;; The communication style used. + (communication-style nil :type (member nil :spawn :sigio :fd-handler)) + ) + +(defun print-connection (conn stream depth) + (declare (ignore depth)) + (print-unreadable-object (conn stream :type t :identity t))) + +(defstruct (singlethreaded-connection (:include connection) + (:conc-name sconn.)) + ;; The SIGINT handler we should restore when the connection is + ;; closed. + saved-sigint-handler + ;; A queue of events. Not all events can be processed in order and + ;; we need a place to stored them. + (event-queue '() :type list) + ;; A counter that is incremented whenever an event is added to the + ;; queue. This is used to detected modifications to the event queue + ;; by interrupts. The counter wraps around. + (events-enqueued 0 :type fixnum)) + +(defstruct (multithreaded-connection (:include connection) + (:conc-name mconn.)) + ;; In multithreaded systems we delegate certain tasks to specific + ;; threads. The `reader-thread' is responsible for reading network + ;; requests from Emacs and sending them to the `control-thread'; the + ;; `control-thread' is responsible for dispatching requests to the + ;; threads that should handle them; the `repl-thread' is the one + ;; that evaluates REPL expressions. The control thread dispatches + ;; all REPL evaluations to the REPL thread and for other requests it + ;; spawns new threads. + reader-thread + control-thread + repl-thread + auto-flush-thread + indentation-cache-thread + ;; List of threads that are currently processing requests. We use + ;; this to find the newest/current thread for an interrupt. In the + ;; future we may store here (thread . request-tag) pairs so that we + ;; can interrupt specific requests. + (active-threads '() :type list) + ) + +(defvar *emacs-connection* nil + "The connection to Emacs currently in use.") + +(defun make-connection (socket stream style) + (let ((conn (funcall (ecase style + (:spawn + #'make-multithreaded-connection) + ((:sigio nil :fd-handler) + #'make-singlethreaded-connection)) + :socket socket + :socket-io stream + :communication-style style))) + (run-hook *new-connection-hook* conn) + (send-to-sentinel `(:add-connection ,conn)) + conn)) + +(defslimefun ping (tag) + tag) + +(defun safe-backtrace () + (ignore-errors + (call-with-debugging-environment + (lambda () (backtrace 0 nil))))) + +(define-condition swank-error (error) + ((backtrace :initarg :backtrace :reader swank-error.backtrace) + (condition :initarg :condition :reader swank-error.condition)) + (:report (lambda (c s) (princ (swank-error.condition c) s))) + (:documentation "Condition which carries a backtrace.")) + +(defun signal-swank-error (condition &optional (backtrace (safe-backtrace))) + (error 'swank-error :condition condition :backtrace backtrace)) + +(defvar *debug-on-swank-protocol-error* nil + "When non-nil invoke the system debugger on errors that were +signalled during decoding/encoding the wire protocol. Do not set this +to T unless you want to debug swank internals.") + +(defmacro with-swank-error-handler ((connection) &body body) + "Close the connection on internal `swank-error's." + (let ((conn (gensym))) + `(let ((,conn ,connection)) + (handler-case + (handler-bind ((swank-error + (lambda (condition) + (when *debug-on-swank-protocol-error* + (invoke-default-debugger condition))))) + (progn . ,body)) + (swank-error (condition) + (close-connection ,conn + (swank-error.condition condition) + (swank-error.backtrace condition))))))) + +(defmacro with-panic-handler ((connection) &body body) + "Close the connection on unhandled `serious-condition's." + (let ((conn (gensym))) + `(let ((,conn ,connection)) + (handler-bind ((serious-condition + (lambda (condition) + (close-connection ,conn condition (safe-backtrace)) + (abort condition)))) + . ,body)))) + +(add-hook *new-connection-hook* 'notify-backend-of-connection) +(defun notify-backend-of-connection (connection) + (declare (ignore connection)) + (emacs-connected)) + + +;;;; Utilities + + +;;;;; Logging + +(defvar *swank-io-package* + (let ((package (make-package :swank-io-package :use '()))) + (import '(nil t quote) package) + package)) + +(defvar *log-events* nil) + +(defun init-log-output () + (unless *log-output* + (setq *log-output* (real-output-stream *error-output*)))) + +(add-hook *after-init-hook* 'init-log-output) + +(defun real-input-stream (stream) + (typecase stream + (synonym-stream + (real-input-stream (symbol-value (synonym-stream-symbol stream)))) + (two-way-stream + (real-input-stream (two-way-stream-input-stream stream))) + (t stream))) + +(defun real-output-stream (stream) + (typecase stream + (synonym-stream + (real-output-stream (symbol-value (synonym-stream-symbol stream)))) + (two-way-stream + (real-output-stream (two-way-stream-output-stream stream))) + (t stream))) + +(defvar *event-history* (make-array 40 :initial-element nil) + "A ring buffer to record events for better error messages.") +(defvar *event-history-index* 0) +(defvar *enable-event-history* t) + +(defun log-event (format-string &rest args) + "Write a message to *terminal-io* when *log-events* is non-nil. +Useful for low level debugging." + (with-standard-io-syntax + (let ((*print-readably* nil) + (*print-pretty* nil) + (*package* *swank-io-package*)) + (when *enable-event-history* + (setf (aref *event-history* *event-history-index*) + (format nil "~?" format-string args)) + (setf *event-history-index* + (mod (1+ *event-history-index*) (length *event-history*)))) + (when *log-events* + (write-string (escape-non-ascii (format nil "~?" format-string args)) + *log-output*) + (force-output *log-output*))))) + +(defun event-history-to-list () + "Return the list of events (older events first)." + (let ((arr *event-history*) + (idx *event-history-index*)) + (concatenate 'list (subseq arr idx) (subseq arr 0 idx)))) + +(defun clear-event-history () + (fill *event-history* nil) + (setq *event-history-index* 0)) + +(defun dump-event-history (stream) + (dolist (e (event-history-to-list)) + (dump-event e stream))) + +(defun dump-event (event stream) + (cond ((stringp event) + (write-string (escape-non-ascii event) stream)) + ((null event)) + (t + (write-string + (escape-non-ascii (format nil "Unexpected event: ~A~%" event)) + stream)))) + +(defun escape-non-ascii (string) + "Return a string like STRING but with non-ascii chars escaped." + (cond ((ascii-string-p string) string) + (t (with-output-to-string (out) + (loop for c across string do + (cond ((ascii-char-p c) (write-char c out)) + (t (format out "\\x~4,'0X" (char-code c))))))))) + +(defun ascii-string-p (o) + (and (stringp o) + (every #'ascii-char-p o))) + +(defun ascii-char-p (c) + (<= (char-code c) 127)) + + +;;;;; Helper macros + +(defmacro dcase (value &body patterns) + "Dispatch VALUE to one of PATTERNS. +A cross between `case' and `destructuring-bind'. +The pattern syntax is: + ((HEAD . ARGS) . BODY) +The list of patterns is searched for a HEAD `eq' to the car of +VALUE. If one is found, the BODY is executed with ARGS bound to the +corresponding values in the CDR of VALUE." + (let ((operator (gensym "op-")) + (operands (gensym "rand-")) + (tmp (gensym "tmp-"))) + `(let* ((,tmp ,value) + (,operator (car ,tmp)) + (,operands (cdr ,tmp))) + (case ,operator + ,@(loop for (pattern . body) in patterns collect + (if (eq pattern t) + `(t ,@body) + (destructuring-bind (op &rest rands) pattern + `(,op (destructuring-bind ,rands ,operands + ,@body))))) + ,@(if (eq (caar (last patterns)) t) + '() + `((t (error "dcase failed: ~S" ,tmp)))))))) + + +;;;; Interrupt handling + +;; Usually we'd like to enter the debugger when an interrupt happens. +;; But for some operations, in particular send&receive, it's crucial +;; that those are not interrupted when the mailbox is in an +;; inconsistent/locked state. Obviously, if send&receive don't work we +;; can't communicate and the debugger will not work. To solve that +;; problem, we try to handle interrupts only at certain safe-points. +;; +;; Whenever an interrupt happens we call the function +;; INVOKE-OR-QUEUE-INTERRUPT. Usually this simply invokes the +;; debugger, but if interrupts are disabled the interrupt is put in a +;; queue for later processing. At safe-points, we call +;; CHECK-SLIME-INTERRUPTS which looks at the queue and invokes the +;; debugger if needed. +;; +;; The queue for interrupts is stored in a thread local variable. +;; WITH-CONNECTION sets it up. WITH-SLIME-INTERRUPTS allows +;; interrupts, i.e. the debugger is entered immediately. When we call +;; "user code" or non-problematic code we allow interrupts. When +;; inside WITHOUT-SLIME-INTERRUPTS, interrupts are queued. When we +;; switch from "user code" to more delicate operations we need to +;; disable interrupts. In particular, interrupts should be disabled +;; for SEND and RECEIVE-IF. + +;; If true execute interrupts, otherwise queue them. +;; Note: `with-connection' binds *pending-slime-interrupts*. +(defvar *slime-interrupts-enabled*) + +(defmacro with-interrupts-enabled% (flag body) + `(progn + ,@(if flag '((check-slime-interrupts))) + (multiple-value-prog1 + (let ((*slime-interrupts-enabled* ,flag)) + ,@body) + ,@(if flag '((check-slime-interrupts)))))) + +(defmacro with-slime-interrupts (&body body) + `(with-interrupts-enabled% t ,body)) + +(defmacro without-slime-interrupts (&body body) + `(with-interrupts-enabled% nil ,body)) + +(defun invoke-or-queue-interrupt (function) + (log-event "invoke-or-queue-interrupt: ~a~%" function) + (cond ((not (boundp '*slime-interrupts-enabled*)) + (without-slime-interrupts + (funcall function))) + (*slime-interrupts-enabled* + (log-event "interrupts-enabled~%") + (funcall function)) + (t + (setq *pending-slime-interrupts* + (nconc *pending-slime-interrupts* + (list function))) + (cond ((cdr *pending-slime-interrupts*) + (log-event "too many queued interrupts~%") + (with-simple-restart (continue "Continue from interrupt") + (handler-bind ((serious-condition #'invoke-slime-debugger)) + (check-slime-interrupts)))) + (t + (log-event "queue-interrupt: ~a~%" function) + (when *interrupt-queued-handler* + (funcall *interrupt-queued-handler*))))))) + + +;;; FIXME: poor name? +(defmacro with-io-redirection ((connection) &body body) + "Execute BODY I/O redirection to CONNECTION. " + `(with-bindings (connection.env ,connection) + . ,body)) + +;; Thread local variable used for flow-control. +;; It's bound by `with-connection'. +(defvar *send-counter*) + +(defmacro with-connection ((connection) &body body) + "Execute BODY in the context of CONNECTION." + `(let ((connection ,connection) + (function (lambda () . ,body))) + (if (eq *emacs-connection* connection) + (funcall function) + (let ((*emacs-connection* connection) + (*pending-slime-interrupts* '()) + (*send-counter* 0)) + (without-slime-interrupts + (with-swank-error-handler (connection) + (with-io-redirection (connection) + (call-with-debugger-hook #'swank-debugger-hook + function)))))))) + +(defun call-with-retry-restart (msg thunk) + (loop (with-simple-restart (retry "~a" msg) + (return (funcall thunk))))) + +(defmacro with-retry-restart ((&key (msg "Retry.")) &body body) + (check-type msg string) + `(call-with-retry-restart ,msg (lambda () ,@body))) + +(defmacro with-struct* ((conc-name get obj) &body body) + (let ((var (gensym))) + `(let ((,var ,obj)) + (macrolet ((,get (slot) + (let ((getter (intern (concatenate 'string + ',(string conc-name) + (string slot)) + (symbol-package ',conc-name)))) + `(,getter ,',var)))) + ,@body)))) + +(defmacro define-special (name doc) + "Define a special variable NAME with doc string DOC. +This is like defvar, but NAME will not be initialized." + `(progn + (defvar ,name) + (setf (documentation ',name 'variable) ,doc))) + + +;;;;; Sentinel +;;; +;;; The sentinel thread manages some global lists. +;;; FIXME: Overdesigned? + +(defvar *connections* '() + "List of all active connections, with the most recent at the front.") + +(defvar *servers* '() + "A list ((server-socket port thread) ...) describing the listening sockets. +Used to close sockets on server shutdown or restart.") + +;; FIXME: we simply access the global variable here. We could ask the +;; sentinel thread instead but then we still have the problem that the +;; connection could be closed before we use it. +(defun default-connection () + "Return the 'default' Emacs connection. +This connection can be used to talk with Emacs when no specific +connection is in use, i.e. *EMACS-CONNECTION* is NIL. + +The default connection is defined (quite arbitrarily) as the most +recently established one." + (car *connections*)) + +(defun start-sentinel () + (unless (find-registered 'sentinel) + (let ((thread (spawn #'sentinel :name "Swank Sentinel"))) + (register-thread 'sentinel thread)))) + +(defun sentinel () + (catch 'exit-sentinel + (loop (sentinel-serve (receive))))) + +(defun send-to-sentinel (msg) + (let ((sentinel (find-registered 'sentinel))) + (cond (sentinel (send sentinel msg)) + (t (sentinel-serve msg))))) + +(defun sentinel-serve (msg) + (dcase msg + ((:add-connection conn) + (push conn *connections*)) + ((:close-connection connection condition backtrace) + (close-connection% connection condition backtrace) + (sentinel-maybe-exit)) + ((:add-server socket port thread) + (push (list socket port thread) *servers*)) + ((:stop-server key port) + (sentinel-stop-server key port) + (sentinel-maybe-exit)))) + +(defun sentinel-stop-server (key value) + (let ((probe (find value *servers* :key (ecase key + (:socket #'car) + (:port #'cadr))))) + (cond (probe + (setq *servers* (delete probe *servers*)) + (destructuring-bind (socket _port thread) probe + (declare (ignore _port)) + (ignore-errors (close-socket socket)) + (when (and thread + (thread-alive-p thread) + (not (eq thread (current-thread)))) + (kill-thread thread)))) + (t + (warn "No server for ~s: ~s" key value))))) + +(defun sentinel-maybe-exit () + (when (and (null *connections*) + (null *servers*) + (and (current-thread) + (eq (find-registered 'sentinel) + (current-thread)))) + (register-thread 'sentinel nil) + (throw 'exit-sentinel nil))) + + +;;;;; Misc + +(defun use-threads-p () + (eq (connection.communication-style *emacs-connection*) :spawn)) + +(defun current-thread-id () + (thread-id (current-thread))) + +(declaim (inline ensure-list)) +(defun ensure-list (thing) + (if (listp thing) thing (list thing))) + + +;;;;; Symbols + +;; FIXME: this docstring is more confusing than helpful. +(defun symbol-status (symbol &optional (package (symbol-package symbol))) + "Returns one of + + :INTERNAL if the symbol is _present_ in PACKAGE as an _internal_ symbol, + + :EXTERNAL if the symbol is _present_ in PACKAGE as an _external_ symbol, + + :INHERITED if the symbol is _inherited_ by PACKAGE through USE-PACKAGE, + but is not _present_ in PACKAGE, + + or NIL if SYMBOL is not _accessible_ in PACKAGE. + + +Be aware not to get confused with :INTERNAL and how \"internal +symbols\" are defined in the spec; there is a slight mismatch of +definition with the Spec and what's commonly meant when talking +about internal symbols most times. As the spec says: + + In a package P, a symbol S is + + _accessible_ if S is either _present_ in P itself or was + inherited from another package Q (which implies + that S is _external_ in Q.) + + You can check that with: (AND (SYMBOL-STATUS S P) T) + + + _present_ if either P is the /home package/ of S or S has been + imported into P or exported from P by IMPORT, or + EXPORT respectively. + + Or more simply, if S is not _inherited_. + + You can check that with: (LET ((STATUS (SYMBOL-STATUS S P))) + (AND STATUS + (NOT (EQ STATUS :INHERITED)))) + + + _external_ if S is going to be inherited into any package that + /uses/ P by means of USE-PACKAGE, MAKE-PACKAGE, or + DEFPACKAGE. + + Note that _external_ implies _present_, since to + make a symbol _external_, you'd have to use EXPORT + which will automatically make the symbol _present_. + + You can check that with: (EQ (SYMBOL-STATUS S P) :EXTERNAL) + + + _internal_ if S is _accessible_ but not _external_. + + You can check that with: (LET ((STATUS (SYMBOL-STATUS S P))) + (AND STATUS + (NOT (EQ STATUS :EXTERNAL)))) + + + Notice that this is *different* to + (EQ (SYMBOL-STATUS S P) :INTERNAL) + because what the spec considers _internal_ is split up into two + explicit pieces: :INTERNAL, and :INHERITED; just as, for instance, + CL:FIND-SYMBOL does. + + The rationale is that most times when you speak about \"internal\" + symbols, you're actually not including the symbols inherited + from other packages, but only about the symbols directly specific + to the package in question. +" + (when package ; may be NIL when symbol is completely uninterned. + (check-type symbol symbol) (check-type package package) + (multiple-value-bind (present-symbol status) + (find-symbol (symbol-name symbol) package) + (and (eq symbol present-symbol) status)))) + +(defun symbol-external-p (symbol &optional (package (symbol-package symbol))) + "True if SYMBOL is external in PACKAGE. +If PACKAGE is not specified, the home package of SYMBOL is used." + (eq (symbol-status symbol package) :external)) + + +;;;; TCP Server + +(defvar *communication-style* (preferred-communication-style)) + +(defvar *dont-close* nil + "Default value of :dont-close argument to start-server and + create-server.") + +(defun start-server (port-file &key (style *communication-style*) + (dont-close *dont-close*)) + "Start the server and write the listen port number to PORT-FILE. +This is the entry point for Emacs." + (setup-server 0 + (lambda (port) (announce-server-port port-file port)) + style dont-close nil)) + +(defun create-server (&key (port default-server-port) + (style *communication-style*) + (dont-close *dont-close*) + backlog) + "Start a SWANK server on PORT running in STYLE. +If DONT-CLOSE is true then the listen socket will accept multiple +connections, otherwise it will be closed after the first." + (setup-server port #'simple-announce-function + style dont-close backlog)) + +(defun find-external-format-or-lose (coding-system) + (or (find-external-format coding-system) + (error "Unsupported coding system: ~s" coding-system))) + +(defparameter *loopback-interface* "127.0.0.1") + +(defmacro restart-loop (form &body clauses) + "Executes FORM, with restart-case CLAUSES which have a chance to modify FORM's +environment before trying again (by returning normally) or giving up (through an +explicit transfer of control), all within an implicit block named nil. +e.g.: (restart-loop (http-request url) (use-value (new) (setq url new)))" + `(loop (restart-case (return ,form) ,@clauses))) + +(defun socket-quest (port backlog) + (restart-loop (create-socket *loopback-interface* port :backlog backlog) + (use-value (&optional (new-port (1+ port))) + :report (lambda (stream) (format stream "Try a port other than ~D" port)) + :interactive + (lambda () + (format *query-io* "Enter port (defaults to ~D): " (1+ port)) + (finish-output *query-io*) ; necessary for tunnels + (ignore-errors (list (parse-integer (read-line *query-io*))))) + (setq port new-port)))) + +(defun setup-server (port announce-fn style dont-close backlog) + (init-log-output) + (let* ((socket (socket-quest port backlog)) + (port (local-port socket))) + (funcall announce-fn port) + (labels ((serve () (accept-connections socket style dont-close)) + (note () (send-to-sentinel `(:add-server ,socket ,port + ,(current-thread)))) + (serve-loop () (note) (loop do (serve) while dont-close))) + (ecase style + (:spawn (initialize-multiprocessing + (lambda () + (start-sentinel) + (spawn #'serve-loop :name (format nil "Swank ~s" port))))) + ((:fd-handler :sigio) + (note) + (add-fd-handler socket #'serve)) + ((nil) (serve-loop)))) + port)) + +(defun stop-server (port) + "Stop server running on PORT." + (send-to-sentinel `(:stop-server :port ,port))) + +(defun restart-server (&key (port default-server-port) + (style *communication-style*) + (dont-close *dont-close*)) + "Stop the server listening on PORT, then start a new SWANK server +on PORT running in STYLE. If DONT-CLOSE is true then the listen socket +will accept multiple connections, otherwise it will be closed after the +first." + (stop-server port) + (sleep 5) + (create-server :port port :style style :dont-close dont-close)) + +(defun accept-connections (socket style dont-close) + (let ((client (unwind-protect + (accept-connection socket :external-format nil + :buffering t) + (unless dont-close + (close-socket socket))))) + (authenticate-client client) + (serve-requests (make-connection socket client style)) + (unless dont-close + (send-to-sentinel `(:stop-server :socket ,socket))))) + +(defun authenticate-client (stream) + (let ((secret (slime-secret))) + (when secret + (set-stream-timeout stream 20) + (let ((first-val (decode-message stream))) + (unless (and (stringp first-val) (string= first-val secret)) + (error "Incoming connection doesn't know the password."))) + (set-stream-timeout stream nil)))) + +(defun slime-secret () + "Finds the magic secret from the user's home directory. Returns nil +if the file doesn't exist; otherwise the first line of the file." + (with-open-file (in + (merge-pathnames (user-homedir-pathname) #p".slime-secret") + :if-does-not-exist nil) + (and in (read-line in nil "")))) + +(defun serve-requests (connection) + "Read and process all requests on connections." + (etypecase connection + (multithreaded-connection + (spawn-threads-for-connection connection)) + (singlethreaded-connection + (ecase (connection.communication-style connection) + ((nil) (simple-serve-requests connection)) + (:sigio (install-sigio-handler connection)) + (:fd-handler (install-fd-handler connection)))))) + +(defun stop-serving-requests (connection) + (etypecase connection + (multithreaded-connection + (cleanup-connection-threads connection)) + (singlethreaded-connection + (ecase (connection.communication-style connection) + ((nil)) + (:sigio (deinstall-sigio-handler connection)) + (:fd-handler (deinstall-fd-handler connection)))))) + +(defun announce-server-port (file port) + (with-open-file (s file + :direction :output + :if-exists :error + :if-does-not-exist :create) + (format s "~S~%" port)) + (simple-announce-function port)) + +(defun simple-announce-function (port) + (when *swank-debug-p* + (format *log-output* "~&;; Swank started at port: ~D.~%" port) + (force-output *log-output*))) + + +;;;;; Event Decoding/Encoding + +(defun decode-message (stream) + "Read an S-expression from STREAM using the SLIME protocol." + (log-event "decode-message~%") + (without-slime-interrupts + (handler-bind ((error #'signal-swank-error)) + (handler-case (read-message stream *swank-io-package*) + (swank-reader-error (c) + `(:reader-error ,(swank-reader-error.packet c) + ,(swank-reader-error.cause c))))))) + +(defun encode-message (message stream) + "Write an S-expression to STREAM using the SLIME protocol." + (log-event "encode-message~%") + (without-slime-interrupts + (handler-bind ((error #'signal-swank-error)) + (write-message message *swank-io-package* stream)))) + + +;;;;; Event Processing + +(defvar *sldb-quit-restart* nil + "The restart that will be invoked when the user calls sldb-quit.") + +;; Establish a top-level restart and execute BODY. +;; Execute K if the restart is invoked. +(defmacro with-top-level-restart ((connection k) &body body) + `(with-connection (,connection) + (restart-case + (let ((*sldb-quit-restart* (find-restart 'abort))) + ,@body) + (abort (&optional v) + :report "Return to SLIME's top level." + (declare (ignore v)) + (force-user-output) + ,k)))) + +(defun handle-requests (connection &optional timeout) + "Read and process :emacs-rex requests. +The processing is done in the extent of the toplevel restart." + (with-connection (connection) + (cond (*sldb-quit-restart* + (process-requests timeout)) + (t + (tagbody + start + (with-top-level-restart (connection (go start)) + (process-requests timeout))))))) + +(defun process-requests (timeout) + "Read and process requests from Emacs." + (loop + (multiple-value-bind (event timeout?) + (wait-for-event `(or (:emacs-rex . _) + (:emacs-channel-send . _)) + timeout) + (when timeout? (return)) + (dcase event + ((:emacs-rex &rest args) (apply #'eval-for-emacs args)) + ((:emacs-channel-send channel (selector &rest args)) + (channel-send channel selector args)))))) + +(defun current-socket-io () + (connection.socket-io *emacs-connection*)) + +(defun close-connection (connection condition backtrace) + (send-to-sentinel `(:close-connection ,connection ,condition ,backtrace))) + +(defun close-connection% (c condition backtrace) + (let ((*debugger-hook* nil)) + (log-event "close-connection: ~a ...~%" condition) + (format *log-output* "~&;; swank:close-connection: ~A~%" + (escape-non-ascii (safe-condition-message condition))) + (stop-serving-requests c) + (close (connection.socket-io c)) + (when (connection.dedicated-output c) + (close (connection.dedicated-output c))) + (setf *connections* (remove c *connections*)) + (run-hook *connection-closed-hook* c) + (when (and condition (not (typep condition 'end-of-file))) + (finish-output *log-output*) + (format *log-output* "~&;; Event history start:~%") + (dump-event-history *log-output*) + (format *log-output* "~ +;; Event history end.~%~ +;; Backtrace:~%~{~A~%~}~ +;; Connection to Emacs lost. [~%~ +;; condition: ~A~%~ +;; type: ~S~%~ +;; style: ~S]~%" + (loop for (i f) in backtrace collect + (ignore-errors + (format nil "~d: ~a" i (escape-non-ascii f)))) + (escape-non-ascii (safe-condition-message condition) ) + (type-of condition) + (connection.communication-style c))) + (finish-output *log-output*) + (log-event "close-connection ~a ... done.~%" condition))) + +;;;;;; Thread based communication + +(defun read-loop (connection) + (let ((input-stream (connection.socket-io connection)) + (control-thread (mconn.control-thread connection))) + (with-swank-error-handler (connection) + (loop (send control-thread (decode-message input-stream)))))) + +(defun dispatch-loop (connection) + (let ((*emacs-connection* connection)) + (with-panic-handler (connection) + (loop (dispatch-event connection (receive)))))) + +(defvar *auto-flush-interval* 0.2) + +(defun auto-flush-loop (stream) + (loop + (when (not (and (open-stream-p stream) + (output-stream-p stream))) + (return nil)) + (force-output stream) + (sleep *auto-flush-interval*))) + +(defgeneric thread-for-evaluation (connection id) + (:documentation "Find or create a thread to evaluate the next request.") + (:method ((connection multithreaded-connection) (id (eql t))) + (spawn-worker-thread connection)) + (:method ((connection multithreaded-connection) (id (eql :find-existing))) + (car (mconn.active-threads connection))) + (:method (connection (id integer)) + (declare (ignorable connection)) + (find-thread id)) + (:method ((connection singlethreaded-connection) id) + (declare (ignorable connection connection id)) + (current-thread))) + +(defun interrupt-worker-thread (connection id) + (let ((thread (thread-for-evaluation connection + (cond ((eq id t) :find-existing) + (t id))))) + (log-event "interrupt-worker-thread: ~a ~a~%" id thread) + (if thread + (etypecase connection + (multithreaded-connection + (interrupt-thread thread + (lambda () + ;; safely interrupt THREAD + (invoke-or-queue-interrupt #'simple-break)))) + (singlethreaded-connection + (simple-break))) + (encode-message (list :debug-condition (current-thread-id) + (format nil "Thread with id ~a not found" + id)) + (current-socket-io))))) + +(defun spawn-worker-thread (connection) + (spawn (lambda () + (with-bindings *default-worker-thread-bindings* + (with-top-level-restart (connection nil) + (apply #'eval-for-emacs + (cdr (wait-for-event `(:emacs-rex . _))))))) + :name "worker")) + +(defun add-active-thread (connection thread) + (etypecase connection + (multithreaded-connection + (push thread (mconn.active-threads connection))) + (singlethreaded-connection))) + +(defun remove-active-thread (connection thread) + (etypecase connection + (multithreaded-connection + (setf (mconn.active-threads connection) + (delete thread (mconn.active-threads connection) :count 1))) + (singlethreaded-connection))) + +(defun dispatch-event (connection event) + "Handle an event triggered either by Emacs or within Lisp." + (log-event "dispatch-event: ~s~%" event) + (dcase event + ((:emacs-rex form package thread-id id) + (let ((thread (thread-for-evaluation connection thread-id))) + (cond (thread + (add-active-thread connection thread) + (send-event thread `(:emacs-rex ,form ,package ,id))) + (t + (encode-message + (list :invalid-rpc id + (format nil "Thread not found: ~s" thread-id)) + (current-socket-io)))))) + ((:return thread &rest args) + (remove-active-thread connection thread) + (encode-message `(:return ,@args) (current-socket-io))) + ((:emacs-interrupt thread-id) + (interrupt-worker-thread connection thread-id)) + (((:write-string + :debug :debug-condition :debug-activate :debug-return :channel-send + :presentation-start :presentation-end + :new-package :new-features :ed :indentation-update + :eval :eval-no-wait :background-message :inspect :ping + :y-or-n-p :read-from-minibuffer :read-string :read-aborted :test-delay + :write-image) + &rest _) + (declare (ignore _)) + (encode-message event (current-socket-io))) + (((:emacs-pong :emacs-return :emacs-return-string) thread-id &rest args) + (send-event (find-thread thread-id) (cons (car event) args))) + ((:emacs-channel-send channel-id msg) + (let ((ch (find-channel channel-id))) + (send-event (channel-thread ch) `(:emacs-channel-send ,ch ,msg)))) + ((:reader-error packet condition) + (encode-message `(:reader-error ,packet + ,(safe-condition-message condition)) + (current-socket-io))))) + + +(defun send-event (thread event) + (log-event "send-event: ~s ~s~%" thread event) + (let ((c *emacs-connection*)) + (etypecase c + (multithreaded-connection + (send thread event)) + (singlethreaded-connection + (setf (sconn.event-queue c) (nconc (sconn.event-queue c) (list event))) + (setf (sconn.events-enqueued c) (mod (1+ (sconn.events-enqueued c)) + most-positive-fixnum)))))) + +(defun send-to-emacs (event) + "Send EVENT to Emacs." + ;;(log-event "send-to-emacs: ~a" event) + (without-slime-interrupts + (let ((c *emacs-connection*)) + (etypecase c + (multithreaded-connection + (send (mconn.control-thread c) event)) + (singlethreaded-connection + (dispatch-event c event))) + (maybe-slow-down)))) + + +;;;;;; Flow control + +;; After sending N (usually 100) messages we slow down and ping Emacs +;; to make sure that everything we have sent so far was received. + +(defconstant send-counter-limit 100) + +(defun maybe-slow-down () + (let ((counter (incf *send-counter*))) + (when (< send-counter-limit counter) + (setf *send-counter* 0) + (ping-pong)))) + +(defun ping-pong () + (let* ((tag (make-tag)) + (pattern `(:emacs-pong ,tag))) + (send-to-emacs `(:ping ,(current-thread-id) ,tag)) + (wait-for-event pattern))) + + +(defun wait-for-event (pattern &optional timeout) + "Scan the event queue for PATTERN and return the event. +If TIMEOUT is 'nil wait until a matching event is enqued. +If TIMEOUT is 't only scan the queue without waiting. +The second return value is t if the timeout expired before a matching +event was found." + (log-event "wait-for-event: ~s ~s~%" pattern timeout) + (without-slime-interrupts + (let ((c *emacs-connection*)) + (etypecase c + (multithreaded-connection + (receive-if (lambda (e) (event-match-p e pattern)) timeout)) + (singlethreaded-connection + (wait-for-event/event-loop c pattern timeout)))))) + +(defun wait-for-event/event-loop (connection pattern timeout) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (let ((event (poll-for-event connection pattern))) + (when event (return (car event)))) + (let ((events-enqueued (sconn.events-enqueued connection)) + (ready (wait-for-input (list (current-socket-io)) timeout))) + (cond ((and timeout (not ready)) + (return (values nil t))) + ((or (/= events-enqueued (sconn.events-enqueued connection)) + (eq ready :interrupt)) + ;; rescan event queue, interrupts may enqueue new events + ) + (t + (assert (equal ready (list (current-socket-io)))) + (dispatch-event connection + (decode-message (current-socket-io)))))))) + +(defun poll-for-event (connection pattern) + (let* ((c connection) + (tail (member-if (lambda (e) (event-match-p e pattern)) + (sconn.event-queue c)))) + (when tail + (setf (sconn.event-queue c) + (nconc (ldiff (sconn.event-queue c) tail) (cdr tail))) + tail))) + +;;; FIXME: Make this use SWANK-MATCH. +(defun event-match-p (event pattern) + (cond ((or (keywordp pattern) (numberp pattern) (stringp pattern) + (member pattern '(nil t))) + (equal event pattern)) + ((symbolp pattern) t) + ((consp pattern) + (case (car pattern) + ((or) (some (lambda (p) (event-match-p event p)) (cdr pattern))) + (t (and (consp event) + (and (event-match-p (car event) (car pattern)) + (event-match-p (cdr event) (cdr pattern))))))) + (t (error "Invalid pattern: ~S" pattern)))) + + + +(defun spawn-threads-for-connection (connection) + (setf (mconn.control-thread connection) + (spawn (lambda () (control-thread connection)) + :name "control-thread")) + connection) + +(defun control-thread (connection) + (with-struct* (mconn. @ connection) + (setf (@ control-thread) (current-thread)) + (setf (@ reader-thread) (spawn (lambda () (read-loop connection)) + :name "reader-thread")) + (setf (@ indentation-cache-thread) + (spawn (lambda () (indentation-cache-loop connection)) + :name "swank-indentation-cache-thread")) + (dispatch-loop connection))) + +(defun cleanup-connection-threads (connection) + (let* ((c connection) + (threads (list (mconn.repl-thread c) + (mconn.reader-thread c) + (mconn.control-thread c) + (mconn.auto-flush-thread c) + (mconn.indentation-cache-thread c)))) + (dolist (thread threads) + (when (and thread + (thread-alive-p thread) + (not (equal (current-thread) thread))) + (kill-thread thread))))) + +;;;;;; Signal driven IO + +(defun install-sigio-handler (connection) + (add-sigio-handler (connection.socket-io connection) + (lambda () (process-io-interrupt connection))) + (handle-requests connection t)) + +(defvar *io-interupt-level* 0) + +(defun process-io-interrupt (connection) + (log-event "process-io-interrupt ~d ...~%" *io-interupt-level*) + (let ((*io-interupt-level* (1+ *io-interupt-level*))) + (invoke-or-queue-interrupt + (lambda () (handle-requests connection t)))) + (log-event "process-io-interrupt ~d ... done ~%" *io-interupt-level*)) + +(defun deinstall-sigio-handler (connection) + (log-event "deinstall-sigio-handler...~%") + (remove-sigio-handlers (connection.socket-io connection)) + (log-event "deinstall-sigio-handler...done~%")) + +;;;;;; SERVE-EVENT based IO + +(defun install-fd-handler (connection) + (add-fd-handler (connection.socket-io connection) + (lambda () (handle-requests connection t))) + (setf (sconn.saved-sigint-handler connection) + (install-sigint-handler + (lambda () + (invoke-or-queue-interrupt + (lambda () (dispatch-interrupt-event connection)))))) + (handle-requests connection t)) + +(defun dispatch-interrupt-event (connection) + (with-connection (connection) + (dispatch-event connection `(:emacs-interrupt ,(current-thread-id))))) + +(defun deinstall-fd-handler (connection) + (log-event "deinstall-fd-handler~%") + (remove-fd-handlers (connection.socket-io connection)) + (install-sigint-handler (sconn.saved-sigint-handler connection))) + +;;;;;; Simple sequential IO + +(defun simple-serve-requests (connection) + (unwind-protect + (with-connection (connection) + (call-with-user-break-handler + (lambda () + (invoke-or-queue-interrupt + (lambda () (dispatch-interrupt-event connection)))) + (lambda () + (with-simple-restart (close-connection "Close SLIME connection.") + (let* ((stdin (real-input-stream *standard-input*)) + (*standard-input* (make-repl-input-stream connection + stdin))) + (tagbody toplevel + (with-top-level-restart (connection (go toplevel)) + (simple-repl)))))))) + (close-connection connection nil (safe-backtrace)))) + +;; this is signalled when our custom stream thinks the end-of-file is reached. +;; (not when the end-of-file on the socket is reached) +(define-condition end-of-repl-input (end-of-file) ()) + +(defun simple-repl () + (loop + (format t "~a> " (package-string-for-prompt *package*)) + (force-output) + (let ((form (handler-case (read) + (end-of-repl-input () (return))))) + (let ((- form) + (values (multiple-value-list (eval form)))) + (setq *** ** ** * * (car values) + /// // // / / values + +++ ++ ++ + + form) + (cond ((null values) (format t "; No values~&")) + (t (mapc (lambda (v) (format t "~s~&" v)) values))))))) + +(defun make-repl-input-stream (connection stdin) + (make-input-stream + (lambda () (repl-input-stream-read connection stdin)))) + +(defun repl-input-stream-read (connection stdin) + (loop + (let* ((socket (connection.socket-io connection)) + (inputs (list socket stdin)) + (ready (wait-for-input inputs))) + (cond ((eq ready :interrupt) + (check-slime-interrupts)) + ((member socket ready) + ;; A Slime request from Emacs is pending; make sure to + ;; redirect IO to the REPL buffer. + (with-simple-restart (process-input "Continue reading input.") + (let ((*sldb-quit-restart* (find-restart 'process-input))) + (with-io-redirection (connection) + (handle-requests connection t))))) + ((member stdin ready) + ;; User typed something into the *inferior-lisp* buffer, + ;; so do not redirect. + (return (read-non-blocking stdin))) + (t (assert (null ready))))))) + +(defun read-non-blocking (stream) + (with-output-to-string (str) + (handler-case + (loop (let ((c (read-char-no-hang stream))) + (unless c (return)) + (write-char c str))) + (end-of-file () (error 'end-of-repl-input :stream stream))))) + + +;;; Channels + +;; FIXME: should be per connection not global. +(defvar *channels* '()) +(defvar *channel-counter* 0) + +(defclass channel () + ((id :reader channel-id) + (thread :initarg :thread :initform (current-thread) :reader channel-thread) + (name :initarg :name :initform nil))) + +(defmethod initialize-instance :after ((ch channel) &key) + (with-slots (id) ch + (setf id (incf *channel-counter*)) + (push (cons id ch) *channels*))) + +(defmethod print-object ((c channel) stream) + (print-unreadable-object (c stream :type t) + (with-slots (id name) c + (format stream "~d ~a" id name)))) + +(defun find-channel (id) + (cdr (assoc id *channels*))) + +(defgeneric channel-send (channel selector args)) + +(defmacro define-channel-method (selector (channel &rest args) &body body) + `(defmethod channel-send (,channel (selector (eql ',selector)) args) + (destructuring-bind ,args args + . ,body))) + +(defun send-to-remote-channel (channel-id msg) + (send-to-emacs `(:channel-send ,channel-id ,msg))) + + + +(defvar *slime-features* nil + "The feature list that has been sent to Emacs.") + +(defun send-oob-to-emacs (object) + (send-to-emacs object)) + +;; FIXME: belongs to swank-repl.lisp +(defun force-user-output () + (force-output (connection.user-io *emacs-connection*))) + +(add-hook *pre-reply-hook* 'force-user-output) + +;; FIXME: belongs to swank-repl.lisp +(defun clear-user-input () + (clear-input (connection.user-input *emacs-connection*))) + +;; FIXME: not thread save. +(defvar *tag-counter* 0) + +(defun make-tag () + (setq *tag-counter* (mod (1+ *tag-counter*) (expt 2 22)))) + +(defun y-or-n-p-in-emacs (format-string &rest arguments) + "Like y-or-n-p, but ask in the Emacs minibuffer." + (let ((tag (make-tag)) + (question (apply #'format nil format-string arguments))) + (force-output) + (send-to-emacs `(:y-or-n-p ,(current-thread-id) ,tag ,question)) + (third (wait-for-event `(:emacs-return ,tag result))))) + +(defun read-from-minibuffer-in-emacs (prompt &optional initial-value) + "Ask user a question in Emacs' minibuffer. Returns \"\" when user +entered nothing, returns NIL when user pressed C-g." + (check-type prompt string) (check-type initial-value (or null string)) + (let ((tag (make-tag))) + (force-output) + (send-to-emacs `(:read-from-minibuffer ,(current-thread-id) ,tag + ,prompt ,initial-value)) + (third (wait-for-event `(:emacs-return ,tag result))))) + +(defstruct (unredable-result + (:constructor make-unredable-result (string)) + (:copier nil) + (:print-object + (lambda (object stream) + (print-unreadable-object (object stream :type t) + (princ (unredable-result-string object) stream))))) + string) + +(defun process-form-for-emacs (form) + "Returns a string which emacs will read as equivalent to +FORM. FORM can contain lists, strings, characters, symbols and +numbers. + +Characters are converted emacs' ?<char> notaion, strings are left +as they are (except for espacing any nested \" chars, numbers are +printed in base 10 and symbols are printed as their symbol-name +converted to lower case." + (etypecase form + (string (format nil "~S" form)) + (cons (format nil "(~A . ~A)" + (process-form-for-emacs (car form)) + (process-form-for-emacs (cdr form)))) + (character (format nil "?~C" form)) + (symbol (concatenate 'string (when (eq (symbol-package form) + #.(find-package "KEYWORD")) + ":") + (string-downcase (symbol-name form)))) + (number (let ((*print-base* 10)) + (princ-to-string form))))) + +(defun eval-in-emacs (form &optional nowait) + "Eval FORM in Emacs. +`slime-enable-evaluate-in-emacs' should be set to T on the Emacs side." + (cond (nowait + (send-to-emacs `(:eval-no-wait ,(process-form-for-emacs form)))) + (t + (force-output) + (let ((tag (make-tag))) + (send-to-emacs `(:eval ,(current-thread-id) ,tag + ,(process-form-for-emacs form))) + (let ((value (caddr (wait-for-event `(:emacs-return ,tag result))))) + (dcase value + ((:unreadable value) (make-unredable-result value)) + ((:ok value) value) + ((:error kind . data) (error "~a: ~{~a~}" kind data)) + ((:abort) (abort)))))))) + +(defvar *swank-wire-protocol-version* nil + "The version of the swank/slime communication protocol.") + +(defslimefun connection-info () + "Return a key-value list of the form: +\(&key PID STYLE LISP-IMPLEMENTATION MACHINE FEATURES PACKAGE VERSION) +PID: is the process-id of Lisp process (or nil, depending on the STYLE) +STYLE: the communication style +LISP-IMPLEMENTATION: a list (&key TYPE NAME VERSION) +FEATURES: a list of keywords +PACKAGE: a list (&key NAME PROMPT) +VERSION: the protocol version" + (let ((c *emacs-connection*)) + (setq *slime-features* *features*) + `(:pid ,(getpid) :style ,(connection.communication-style c) + :encoding (:coding-systems + ,(loop for cs in '("utf-8-unix" "iso-latin-1-unix") + when (find-external-format cs) collect cs)) + :lisp-implementation (:type ,(lisp-implementation-type) + :name ,(lisp-implementation-type-name) + :version ,(lisp-implementation-version) + :program ,(lisp-implementation-program)) + :machine (:instance ,(machine-instance) + :type ,(machine-type) + :version ,(machine-version)) + :features ,(features-for-emacs) + :modules ,*modules* + :package (:name ,(package-name *package*) + :prompt ,(package-string-for-prompt *package*)) + :version ,*swank-wire-protocol-version*))) + +(defun debug-on-swank-error () + (assert (eq *debug-on-swank-protocol-error* *debug-swank-backend*)) + *debug-on-swank-protocol-error*) + +(defun (setf debug-on-swank-error) (new-value) + (setf *debug-on-swank-protocol-error* new-value) + (setf *debug-swank-backend* new-value)) + +(defslimefun toggle-debug-on-swank-error () + (setf (debug-on-swank-error) (not (debug-on-swank-error)))) + + +;;;; Reading and printing + +(define-special *buffer-package* + "Package corresponding to slime-buffer-package. + +EVAL-FOR-EMACS binds *buffer-package*. Strings originating from a slime +buffer are best read in this package. See also FROM-STRING and TO-STRING.") + +(define-special *buffer-readtable* + "Readtable associated with the current buffer") + +(defmacro with-buffer-syntax ((&optional package) &body body) + "Execute BODY with appropriate *package* and *readtable* bindings. + +This should be used for code that is conceptionally executed in an +Emacs buffer." + `(call-with-buffer-syntax ,package (lambda () ,@body))) + +(defun call-with-buffer-syntax (package fun) + (let ((*package* (if package + (guess-buffer-package package) + *buffer-package*))) + ;; Don't shadow *readtable* unnecessarily because that prevents + ;; the user from assigning to it. + (if (eq *readtable* *buffer-readtable*) + (call-with-syntax-hooks fun) + (let ((*readtable* *buffer-readtable*)) + (call-with-syntax-hooks fun))))) + +(defmacro without-printing-errors ((&key object stream + (msg "<<error printing object>>")) + &body body) + "Catches errors during evaluation of BODY and prints MSG instead." + `(handler-case (progn ,@body) + (serious-condition () + ,(cond ((and stream object) + (let ((gstream (gensym "STREAM+"))) + `(let ((,gstream ,stream)) + (print-unreadable-object (,object ,gstream :type t + :identity t) + (write-string ,msg ,gstream))))) + (stream + `(write-string ,msg ,stream)) + (object + `(with-output-to-string (s) + (print-unreadable-object (,object s :type t :identity t) + (write-string ,msg s)))) + (t msg))))) + +(defun to-string (object) + "Write OBJECT in the *BUFFER-PACKAGE*. +The result may not be readable. Handles problems with PRINT-OBJECT methods +gracefully." + (with-buffer-syntax () + (let ((*print-readably* nil)) + (without-printing-errors (:object object :stream nil) + (prin1-to-string object))))) + +(defun from-string (string) + "Read string in the *BUFFER-PACKAGE*" + (with-buffer-syntax () + (let ((*read-suppress* nil)) + (values (read-from-string string))))) + +(defun parse-string (string package) + "Read STRING in PACKAGE." + (with-buffer-syntax (package) + (let ((*read-suppress* nil)) + (read-from-string string)))) + +;; FIXME: deal with #\| etc. hard to do portably. +(defun tokenize-symbol (string) + "STRING is interpreted as the string representation of a symbol +and is tokenized accordingly. The result is returned in three +values: The package identifier part, the actual symbol identifier +part, and a flag if the STRING represents a symbol that is +internal to the package identifier part. (Notice that the flag is +also true with an empty package identifier part, as the STRING is +considered to represent a symbol internal to some current package.)" + (let ((package (let ((pos (position #\: string))) + (if pos (subseq string 0 pos) nil))) + (symbol (let ((pos (position #\: string :from-end t))) + (if pos (subseq string (1+ pos)) string))) + (internp (not (= (count #\: string) 1)))) + (values symbol package internp))) + +(defun tokenize-symbol-thoroughly (string) + "This version of TOKENIZE-SYMBOL handles escape characters." + (let ((package nil) + (token (make-array (length string) :element-type 'character + :fill-pointer 0)) + (backslash nil) + (vertical nil) + (internp nil)) + (loop for char across string do + (cond + (backslash + (vector-push-extend char token) + (setq backslash nil)) + ((char= char #\\) ; Quotes next character, even within |...| + (setq backslash t)) + ((char= char #\|) + (setq vertical (not vertical))) + (vertical + (vector-push-extend char token)) + ((char= char #\:) + (cond ((and package internp) + (return-from tokenize-symbol-thoroughly)) + (package + (setq internp t)) + (t + (setq package token + token (make-array (length string) + :element-type 'character + :fill-pointer 0))))) + (t + (vector-push-extend (casify-char char) token)))) + (unless vertical + (values token package (or (not package) internp))))) + +(defun untokenize-symbol (package-name internal-p symbol-name) + "The inverse of TOKENIZE-SYMBOL. + + (untokenize-symbol \"quux\" nil \"foo\") ==> \"quux:foo\" + (untokenize-symbol \"quux\" t \"foo\") ==> \"quux::foo\" + (untokenize-symbol nil nil \"foo\") ==> \"foo\" +" + (cond ((not package-name) symbol-name) + (internal-p (cat package-name "::" symbol-name)) + (t (cat package-name ":" symbol-name)))) + +(defun casify-char (char) + "Convert CHAR accoring to readtable-case." + (ecase (readtable-case *readtable*) + (:preserve char) + (:upcase (char-upcase char)) + (:downcase (char-downcase char)) + (:invert (if (upper-case-p char) + (char-downcase char) + (char-upcase char))))) + + +(defun find-symbol-with-status (symbol-name status + &optional (package *package*)) + (multiple-value-bind (symbol flag) (find-symbol symbol-name package) + (if (and flag (eq flag status)) + (values symbol flag) + (values nil nil)))) + +(defun parse-symbol (string &optional (package *package*)) + "Find the symbol named STRING. +Return the symbol and a flag indicating whether the symbols was found." + (multiple-value-bind (sname pname internalp) + (tokenize-symbol-thoroughly string) + (when sname + (let ((package (cond ((string= pname "") keyword-package) + (pname (find-package pname)) + (t package)))) + (if package + (multiple-value-bind (symbol flag) + (if internalp + (find-symbol sname package) + (find-symbol-with-status sname ':external package)) + (values symbol flag sname package)) + (values nil nil nil nil)))))) + +(defun parse-symbol-or-lose (string &optional (package *package*)) + (multiple-value-bind (symbol status) (parse-symbol string package) + (if status + (values symbol status) + (error "Unknown symbol: ~A [in ~A]" string package)))) + +(defun parse-package (string) + "Find the package named STRING. +Return the package or nil." + ;; STRING comes usually from a (in-package STRING) form. + (ignore-errors + (find-package (let ((*package* *swank-io-package*)) + (read-from-string string))))) + +(defun unparse-name (string) + "Print the name STRING according to the current printer settings." + ;; this is intended for package or symbol names + (subseq (prin1-to-string (make-symbol string)) 2)) + +(defun guess-package (string) + "Guess which package corresponds to STRING. +Return nil if no package matches." + (when string + (or (find-package string) + (parse-package string) + (if (find #\! string) ; for SBCL + (guess-package (substitute #\- #\! string)))))) + +(defvar *readtable-alist* (default-readtable-alist) + "An alist mapping package names to readtables.") + +(defun guess-buffer-readtable (package-name) + (let ((package (guess-package package-name))) + (or (and package + (cdr (assoc (package-name package) *readtable-alist* + :test #'string=))) + *readtable*))) + + +;;;; Evaluation + +(defvar *pending-continuations* '() + "List of continuations for Emacs. (thread local)") + +(defun guess-buffer-package (string) + "Return a package for STRING. +Fall back to the current if no such package exists." + (or (and string (guess-package string)) + *package*)) + +(defun eval-for-emacs (form buffer-package id) + "Bind *BUFFER-PACKAGE* to BUFFER-PACKAGE and evaluate FORM. +Return the result to the continuation ID. +Errors are trapped and invoke our debugger." + (let (ok result condition) + (unwind-protect + (let ((*buffer-package* (guess-buffer-package buffer-package)) + (*buffer-readtable* (guess-buffer-readtable buffer-package)) + (*pending-continuations* (cons id *pending-continuations*))) + (check-type *buffer-package* package) + (check-type *buffer-readtable* readtable) + ;; APPLY would be cleaner than EVAL. + ;; (setq result (apply (car form) (cdr form))) + (handler-bind ((t (lambda (c) (setf condition c)))) + (setq result (with-slime-interrupts (eval form)))) + (run-hook *pre-reply-hook*) + (setq ok t)) + (send-to-emacs `(:return ,(current-thread) + ,(if ok + `(:ok ,result) + `(:abort ,(prin1-to-string condition))) + ,id))))) + +(defvar *echo-area-prefix* "=> " + "A prefix that `format-values-for-echo-area' should use.") + +(defun format-values-for-echo-area (values) + (with-buffer-syntax () + (let ((*print-readably* nil)) + (cond ((null values) "; No value") + ((and (integerp (car values)) (null (cdr values))) + (let ((i (car values))) + (format nil "~A~D (~a bit~:p, #x~X, #o~O, #b~B)" + *echo-area-prefix* + i (integer-length i) i i i))) + ((and (typep (car values) 'ratio) + (null (cdr values)) + (ignore-errors + ;; The ratio may be to large to be represented as a single float + (format nil "~A~D (~:*~f)" + *echo-area-prefix* + (car values))))) + (t (format nil "~a~{~S~^, ~}" *echo-area-prefix* values)))))) + +(defmacro values-to-string (values) + `(format-values-for-echo-area (multiple-value-list ,values))) + +(defslimefun interactive-eval (string) + (with-buffer-syntax () + (with-retry-restart (:msg "Retry SLIME interactive evaluation request.") + (let ((values (multiple-value-list (eval (from-string string))))) + (finish-output) + (format-values-for-echo-area values))))) + +(defslimefun eval-and-grab-output (string) + (with-buffer-syntax () + (with-retry-restart (:msg "Retry SLIME evaluation request.") + (let* ((s (make-string-output-stream)) + (*standard-output* s) + (values (multiple-value-list (eval (from-string string))))) + (list (get-output-stream-string s) + (format nil "~{~S~^~%~}" values)))))) + +(defun eval-region (string) + "Evaluate STRING. +Return the results of the last form as a list and as secondary value the +last form." + (with-input-from-string (stream string) + (let (- values) + (loop + (let ((form (read stream nil stream))) + (when (eq form stream) + (finish-output) + (return (values values -))) + (setq - form) + (setq values (multiple-value-list (eval form))) + (finish-output)))))) + +(defslimefun interactive-eval-region (string) + (with-buffer-syntax () + (with-retry-restart (:msg "Retry SLIME interactive evaluation request.") + (format-values-for-echo-area (eval-region string))))) + +(defslimefun re-evaluate-defvar (form) + (with-buffer-syntax () + (with-retry-restart (:msg "Retry SLIME evaluation request.") + (let ((form (read-from-string form))) + (destructuring-bind (dv name &optional value doc) form + (declare (ignore value doc)) + (assert (eq dv 'defvar)) + (makunbound name) + (prin1-to-string (eval form))))))) + +(defvar *swank-pprint-bindings* + `((*print-pretty* . t) + (*print-level* . nil) + (*print-length* . nil) + (*print-circle* . t) + (*print-gensym* . t) + (*print-readably* . nil)) + "A list of variables bindings during pretty printing. +Used by pprint-eval.") + +(defun swank-pprint (values) + "Bind some printer variables and pretty print each object in VALUES." + (with-buffer-syntax () + (with-bindings *swank-pprint-bindings* + (cond ((null values) "; No value") + (t (with-output-to-string (*standard-output*) + (dolist (o values) + (pprint o) + (terpri)))))))) + +(defslimefun pprint-eval (string) + (with-buffer-syntax () + (let* ((s (make-string-output-stream)) + (values + (let ((*standard-output* s) + (*trace-output* s)) + (multiple-value-list (eval (read-from-string string)))))) + (cat (get-output-stream-string s) + (swank-pprint values))))) + +(defslimefun set-package (name) + "Set *package* to the package named NAME. +Return the full package-name and the string to use in the prompt." + (let ((p (guess-package name))) + (assert (packagep p) nil "Package ~a doesn't exist." name) + (setq *package* p) + (list (package-name p) (package-string-for-prompt p)))) + +(defun cat (&rest strings) + "Concatenate all arguments and make the result a string." + (with-output-to-string (out) + (dolist (s strings) + (etypecase s + (string (write-string s out)) + (character (write-char s out)))))) + +(defun truncate-string (string width &optional ellipsis) + (let ((len (length string))) + (cond ((< len width) string) + (ellipsis (cat (subseq string 0 width) ellipsis)) + (t (subseq string 0 width))))) + +(defun call/truncated-output-to-string (length function + &optional (ellipsis "..")) + "Call FUNCTION with a new stream, return the output written to the stream. +If FUNCTION tries to write more than LENGTH characters, it will be +aborted and return immediately with the output written so far." + (let ((buffer (make-string (+ length (length ellipsis)))) + (fill-pointer 0)) + (block buffer-full + (flet ((write-output (string) + (let* ((free (- length fill-pointer)) + (count (min free (length string)))) + (replace buffer string :start1 fill-pointer :end2 count) + (incf fill-pointer count) + (when (> (length string) free) + (replace buffer ellipsis :start1 fill-pointer) + (return-from buffer-full buffer))))) + (let ((stream (make-output-stream #'write-output))) + (funcall function stream) + (finish-output stream) + (subseq buffer 0 fill-pointer)))))) + +(defmacro with-string-stream ((var &key length bindings) + &body body) + (cond ((and (not bindings) (not length)) + `(with-output-to-string (,var) . ,body)) + ((not bindings) + `(call/truncated-output-to-string + ,length (lambda (,var) . ,body))) + (t + `(with-bindings ,bindings + (with-string-stream (,var :length ,length) + . ,body))))) + +(defun to-line (object &optional width) + "Print OBJECT to a single line. Return the string." + (let ((width (or width 512))) + (without-printing-errors (:object object :stream nil) + (with-string-stream (stream :length width) + (write object :stream stream :right-margin width :lines 1))))) + +(defun escape-string (string stream &key length (map '((#\" . "\\\"") + (#\\ . "\\\\")))) + "Write STRING to STREAM surronded by double-quotes. +LENGTH -- if non-nil truncate output after LENGTH chars. +MAP -- rewrite the chars in STRING according to this alist." + (let ((limit (or length array-dimension-limit))) + (write-char #\" stream) + (loop for c across string + for i from 0 do + (when (= i limit) + (write-string "..." stream) + (return)) + (let ((probe (assoc c map))) + (cond (probe (write-string (cdr probe) stream)) + (t (write-char c stream))))) + (write-char #\" stream))) + + +;;;; Prompt + +;; FIXME: do we really need 45 lines of code just to figure out the +;; prompt? + +(defvar *canonical-package-nicknames* + `((:common-lisp-user . :cl-user)) + "Canonical package names to use instead of shortest name/nickname.") + +(defvar *auto-abbreviate-dotted-packages* t + "Abbreviate dotted package names to their last component if T.") + +(defun package-string-for-prompt (package) + "Return the shortest nickname (or canonical name) of PACKAGE." + (unparse-name + (or (canonical-package-nickname package) + (auto-abbreviated-package-name package) + (shortest-package-nickname package)))) + +(defun canonical-package-nickname (package) + "Return the canonical package nickname, if any, of PACKAGE." + (let ((name (cdr (assoc (package-name package) *canonical-package-nicknames* + :test #'string=)))) + (and name (string name)))) + +(defun auto-abbreviated-package-name (package) + "Return an abbreviated 'name' for PACKAGE. + +N.B. this is not an actual package name or nickname." + (when *auto-abbreviate-dotted-packages* + (loop with package-name = (package-name package) + with offset = nil + do (let ((last-dot-pos (position #\. package-name :end offset + :from-end t))) + (unless last-dot-pos + (return nil)) + ;; If a dot chunk contains only numbers, that chunk most + ;; likely represents a version number; so we collect the + ;; next chunks, too, until we find one with meat. + (let ((name (subseq package-name (1+ last-dot-pos) offset))) + (if (notevery #'digit-char-p name) + (return (subseq package-name (1+ last-dot-pos))) + (setq offset last-dot-pos))))))) + +(defun shortest-package-nickname (package) + "Return the shortest nickname of PACKAGE." + (loop for name in (cons (package-name package) (package-nicknames package)) + for shortest = name then (if (< (length name) (length shortest)) + name + shortest) + finally (return shortest))) + + + +(defslimefun ed-in-emacs (&optional what) + "Edit WHAT in Emacs. + +WHAT can be: + A pathname or a string, + A list (PATHNAME-OR-STRING &key LINE COLUMN POSITION), + A function name (symbol or cons), + NIL. " + (flet ((canonicalize-filename (filename) + (pathname-to-filename (or (probe-file filename) filename)))) + (let ((target + (etypecase what + (null nil) + ((or string pathname) + `(:filename ,(canonicalize-filename what))) + ((cons (or string pathname) *) + `(:filename ,(canonicalize-filename (car what)) ,@(cdr what))) + ((or symbol cons) + `(:function-name ,(prin1-to-string what)))))) + (cond (*emacs-connection* (send-oob-to-emacs `(:ed ,target))) + ((default-connection) + (with-connection ((default-connection)) + (send-oob-to-emacs `(:ed ,target)))) + (t (error "No connection")))))) + +(defslimefun inspect-in-emacs (what &key wait) + "Inspect WHAT in Emacs. If WAIT is true (default NIL) blocks until the +inspector has been closed in Emacs." + (flet ((send-it () + (let ((tag (when wait (make-tag))) + (thread (when wait (current-thread-id)))) + (with-buffer-syntax () + (reset-inspector) + (send-oob-to-emacs `(:inspect ,(inspect-object what) + ,thread + ,tag))) + (when wait + (wait-for-event `(:emacs-return ,tag result)))))) + (cond + (*emacs-connection* + (send-it)) + ((default-connection) + (with-connection ((default-connection)) + (send-it)))) + what)) + +(defslimefun value-for-editing (form) + "Return a readable value of FORM for editing in Emacs. +FORM is expected, but not required, to be SETF'able." + ;; FIXME: Can we check FORM for setfability? -luke (12/Mar/2005) + (with-buffer-syntax () + (let* ((value (eval (read-from-string form))) + (*print-length* nil)) + (prin1-to-string value)))) + +(defslimefun commit-edited-value (form value) + "Set the value of a setf'able FORM to VALUE. +FORM and VALUE are both strings from Emacs." + (with-buffer-syntax () + (eval `(setf ,(read-from-string form) + ,(read-from-string (concatenate 'string "`" value)))) + t)) + +(defun background-message (format-string &rest args) + "Display a message in Emacs' echo area. + +Use this function for informative messages only. The message may even +be dropped if we are too busy with other things." + (when *emacs-connection* + (send-to-emacs `(:background-message + ,(apply #'format nil format-string args))))) + +;; This is only used by the test suite. +(defun sleep-for (seconds) + "Sleep for at least SECONDS seconds. +This is just like cl:sleep but guarantees to sleep +at least SECONDS." + (let* ((start (get-internal-real-time)) + (end (+ start + (* seconds internal-time-units-per-second)))) + (loop + (let ((now (get-internal-real-time))) + (cond ((< end now) (return)) + (t (sleep (/ (- end now) + internal-time-units-per-second)))))))) + + +;;;; Debugger + +(defun invoke-slime-debugger (condition) + "Sends a message to Emacs declaring that the debugger has been entered, +then waits to handle further requests from Emacs. Eventually returns +after Emacs causes a restart to be invoked." + (without-slime-interrupts + (cond (*emacs-connection* + (debug-in-emacs condition)) + ((default-connection) + (with-connection ((default-connection)) + (debug-in-emacs condition)))))) + +(define-condition invoke-default-debugger () ()) + +(defun swank-debugger-hook (condition hook) + "Debugger function for binding *DEBUGGER-HOOK*." + (declare (ignore hook)) + (handler-case + (call-with-debugger-hook #'swank-debugger-hook + (lambda () (invoke-slime-debugger condition))) + (invoke-default-debugger () + (invoke-default-debugger condition)))) + +(defun invoke-default-debugger (condition) + (call-with-debugger-hook nil (lambda () (invoke-debugger condition)))) + +(defvar *global-debugger* t + "Non-nil means the Swank debugger hook will be installed globally.") + +(add-hook *new-connection-hook* 'install-debugger) +(defun install-debugger (connection) + (declare (ignore connection)) + (when *global-debugger* + (install-debugger-globally #'swank-debugger-hook))) + +;;;;; Debugger loop +;;; +;;; These variables are dynamically bound during debugging. +;;; +(defvar *swank-debugger-condition* nil + "The condition being debugged.") + +(defvar *sldb-level* 0 + "The current level of recursive debugging.") + +(defvar *sldb-initial-frames* 20 + "The initial number of backtrace frames to send to Emacs.") + +(defvar *sldb-restarts* nil + "The list of currenlty active restarts.") + +(defvar *sldb-stepping-p* nil + "True during execution of a step command.") + +(defun debug-in-emacs (condition) + (let ((*swank-debugger-condition* condition) + (*sldb-restarts* (compute-restarts condition)) + (*sldb-quit-restart* (and *sldb-quit-restart* + (find-restart *sldb-quit-restart*))) + (*package* (or (and (boundp '*buffer-package*) + (symbol-value '*buffer-package*)) + *package*)) + (*sldb-level* (1+ *sldb-level*)) + (*sldb-stepping-p* nil)) + (force-user-output) + (call-with-debugging-environment + (lambda () + (sldb-loop *sldb-level*))))) + +(defun sldb-loop (level) + (unwind-protect + (loop + (with-simple-restart (abort "Return to sldb level ~D." level) + (send-to-emacs + (list* :debug (current-thread-id) level + (debugger-info-for-emacs 0 *sldb-initial-frames*))) + (send-to-emacs + (list :debug-activate (current-thread-id) level nil)) + (loop + (handler-case + (dcase (wait-for-event + `(or (:emacs-rex . _) + (:sldb-return ,(1+ level)))) + ((:emacs-rex &rest args) (apply #'eval-for-emacs args)) + ((:sldb-return _) (declare (ignore _)) (return nil))) + (sldb-condition (c) + (handle-sldb-condition c)))))) + (send-to-emacs `(:debug-return + ,(current-thread-id) ,level ,*sldb-stepping-p*)) + (wait-for-event `(:sldb-return ,(1+ level)) t) ; clean event-queue + (when (> level 1) + (send-event (current-thread) `(:sldb-return ,level))))) + +(defun handle-sldb-condition (condition) + "Handle an internal debugger condition. +Rather than recursively debug the debugger (a dangerous idea!), these +conditions are simply reported." + (let ((real-condition (original-condition condition))) + (send-to-emacs `(:debug-condition ,(current-thread-id) + ,(princ-to-string real-condition))))) + +(defun %%condition-message (condition) + (let ((limit (ash 1 16))) + (with-string-stream (stream :length limit) + (handler-case + (let ((*print-readably* nil) + (*print-pretty* t) + (*print-right-margin* 65) + (*print-circle* t) + (*print-length* (or *print-length* limit)) + (*print-level* (or *print-level* limit)) + (*print-lines* (or *print-lines* limit))) + (print-condition condition stream)) + (serious-condition (c) + (ignore-errors + (with-standard-io-syntax + (let ((*print-readably* nil)) + (format stream "~&Error (~a) during printing: " (type-of c)) + (print-unreadable-object (condition stream :type t + :identity t)))))))))) + +(defun %condition-message (condition) + (string-trim #(#\newline #\space #\tab) + (%%condition-message condition))) + +(defvar *sldb-condition-printer* #'%condition-message + "Function called to print a condition to an SLDB buffer.") + +(defun safe-condition-message (condition) + "Print condition to a string, handling any errors during printing." + (funcall *sldb-condition-printer* condition)) + +(defun debugger-condition-for-emacs () + (list (safe-condition-message *swank-debugger-condition*) + (format nil " [Condition of type ~S]" + (type-of *swank-debugger-condition*)) + (condition-extras *swank-debugger-condition*))) + +(defun format-restarts-for-emacs () + "Return a list of restarts for *swank-debugger-condition* in a +format suitable for Emacs." + (let ((*print-right-margin* most-positive-fixnum)) + (loop for restart in *sldb-restarts* collect + (list (format nil "~:[~;*~]~a" + (eq restart *sldb-quit-restart*) + (restart-name restart)) + (with-output-to-string (stream) + (without-printing-errors (:object restart + :stream stream + :msg "<<error printing restart>>") + (princ restart stream))))))) + +;;;;; SLDB entry points + +(defslimefun sldb-break-with-default-debugger (dont-unwind) + "Invoke the default debugger." + (cond (dont-unwind + (invoke-default-debugger *swank-debugger-condition*)) + (t + (signal 'invoke-default-debugger)))) + +(defslimefun backtrace (start end) + "Return a list ((I FRAME PLIST) ...) of frames from START to END. + +I is an integer, and can be used to reference the corresponding frame +from Emacs; FRAME is a string representation of an implementation's +frame." + (loop for frame in (compute-backtrace start end) + for i from start collect + (list* i (frame-to-string frame) + (ecase (frame-restartable-p frame) + ((nil) nil) + ((t) `((:restartable t))))))) + +(defun frame-to-string (frame) + (with-string-stream (stream :length (* (or *print-lines* 1) + (or *print-right-margin* 100)) + :bindings *backtrace-printer-bindings*) + (handler-case (print-frame frame stream) + (serious-condition () + (format stream "[error printing frame]"))))) + +(defslimefun debugger-info-for-emacs (start end) + "Return debugger state, with stack frames from START to END. +The result is a list: + (condition ({restart}*) ({stack-frame}*) (cont*)) +where + condition ::= (description type [extra]) + restart ::= (name description) + stack-frame ::= (number description [plist]) + extra ::= (:references and other random things) + cont ::= continutation + plist ::= (:restartable {nil | t | :unknown}) + +condition---a pair of strings: message, and type. If show-source is +not nil it is a frame number for which the source should be displayed. + +restart---a pair of strings: restart name, and description. + +stack-frame---a number from zero (the top), and a printed +representation of the frame's call. + +continutation---the id of a pending Emacs continuation. + +Below is an example return value. In this case the condition was a +division by zero (multi-line description), and only one frame is being +fetched (start=0, end=1). + + ((\"Arithmetic error DIVISION-BY-ZERO signalled. +Operation was KERNEL::DIVISION, operands (1 0).\" + \"[Condition of type DIVISION-BY-ZERO]\") + ((\"ABORT\" \"Return to Slime toplevel.\") + (\"ABORT\" \"Return to Top-Level.\")) + ((0 \"(KERNEL::INTEGER-/-INTEGER 1 0)\" (:restartable nil))) + (4))" + (list (debugger-condition-for-emacs) + (format-restarts-for-emacs) + (backtrace start end) + *pending-continuations*)) + +(defun nth-restart (index) + (nth index *sldb-restarts*)) + +(defslimefun invoke-nth-restart (index) + (let ((restart (nth-restart index))) + (when restart + (invoke-restart-interactively restart)))) + +(defslimefun sldb-abort () + (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name))) + +(defslimefun sldb-continue () + (continue)) + +(defun coerce-to-condition (datum args) + (etypecase datum + (string (make-condition 'simple-error :format-control datum + :format-arguments args)) + (symbol (apply #'make-condition datum args)))) + +(defslimefun simple-break (&optional (datum "Interrupt from Emacs") &rest args) + (with-simple-restart (continue "Continue from break.") + (invoke-slime-debugger (coerce-to-condition datum args)))) + +;; FIXME: (last (compute-restarts)) looks dubious. +(defslimefun throw-to-toplevel () + "Invoke the ABORT-REQUEST restart abort an RPC from Emacs. +If we are not evaluating an RPC then ABORT instead." + (let ((restart (or (and *sldb-quit-restart* + (find-restart *sldb-quit-restart*)) + (car (last (compute-restarts)))))) + (cond (restart (invoke-restart restart)) + (t (format nil "Restart not active [~s]" *sldb-quit-restart*))))) + +(defslimefun invoke-nth-restart-for-emacs (sldb-level n) + "Invoke the Nth available restart. +SLDB-LEVEL is the debug level when the request was made. If this +has changed, ignore the request." + (when (= sldb-level *sldb-level*) + (invoke-nth-restart n))) + +(defun wrap-sldb-vars (form) + `(let ((*sldb-level* ,*sldb-level*)) + ,form)) + +(defun eval-in-frame-aux (frame string package print) + (let* ((form (wrap-sldb-vars (parse-string string package))) + (values (multiple-value-list (eval-in-frame form frame)))) + (with-buffer-syntax (package) + (funcall print values)))) + +(defslimefun eval-string-in-frame (string frame package) + (eval-in-frame-aux frame string package #'format-values-for-echo-area)) + +(defslimefun pprint-eval-string-in-frame (string frame package) + (eval-in-frame-aux frame string package #'swank-pprint)) + +(defslimefun frame-package-name (frame) + (let ((pkg (frame-package frame))) + (cond (pkg (package-name pkg)) + (t (with-buffer-syntax () (package-name *package*)))))) + +(defslimefun frame-locals-and-catch-tags (index) + "Return a list (LOCALS TAGS) for vars and catch tags in the frame INDEX. +LOCALS is a list of the form ((&key NAME ID VALUE) ...). +TAGS has is a list of strings." + (list (frame-locals-for-emacs index) + (mapcar #'to-string (frame-catch-tags index)))) + +(defun frame-locals-for-emacs (index) + (with-bindings *backtrace-printer-bindings* + (loop for var in (frame-locals index) collect + (destructuring-bind (&key name id value) var + (list :name (let ((*package* (or (frame-package index) *package*))) + (prin1-to-string name)) + :id id + :value (to-line value *print-right-margin*)))))) + +(defslimefun sldb-disassemble (index) + (with-output-to-string (*standard-output*) + (disassemble-frame index))) + +(defslimefun sldb-return-from-frame (index string) + (let ((form (from-string string))) + (to-string (multiple-value-list (return-from-frame index form))))) + +(defslimefun sldb-break (name) + (with-buffer-syntax () + (sldb-break-at-start (read-from-string name)))) + +(defmacro define-stepper-function (name backend-function-name) + `(defslimefun ,name (frame) + (cond ((sldb-stepper-condition-p *swank-debugger-condition*) + (setq *sldb-stepping-p* t) + (,backend-function-name)) + ((find-restart 'continue) + (activate-stepping frame) + (setq *sldb-stepping-p* t) + (continue)) + (t + (error "Not currently single-stepping, ~ +and no continue restart available."))))) + +(define-stepper-function sldb-step sldb-step-into) +(define-stepper-function sldb-next sldb-step-next) +(define-stepper-function sldb-out sldb-step-out) + +(defslimefun toggle-break-on-signals () + (setq *break-on-signals* (not *break-on-signals*)) + (format nil "*break-on-signals* = ~a" *break-on-signals*)) + +(defslimefun sdlb-print-condition () + (princ-to-string *swank-debugger-condition*)) + + +;;;; Compilation Commands. + +(defstruct (:compilation-result + (:type list) :named) + notes + (successp nil :type boolean) + (duration 0.0 :type float) + (loadp nil :type boolean) + (faslfile nil :type (or null string))) + +(defun measure-time-interval (fun) + "Call FUN and return the first return value and the elapsed time. +The time is measured in seconds." + (declare (type function fun)) + (let ((before (get-internal-real-time))) + (values + (funcall fun) + (/ (- (get-internal-real-time) before) + (coerce internal-time-units-per-second 'float))))) + +(defun make-compiler-note (condition) + "Make a compiler note data structure from a compiler-condition." + (declare (type compiler-condition condition)) + (list* :message (message condition) + :severity (severity condition) + :location (location condition) + :references (references condition) + (let ((s (source-context condition))) + (if s (list :source-context s))))) + +(defun collect-notes (function) + (let ((notes '())) + (multiple-value-bind (result seconds) + (handler-bind ((compiler-condition + (lambda (c) (push (make-compiler-note c) notes)))) + (measure-time-interval + (lambda () + ;; To report location of error-signaling toplevel forms + ;; for errors in EVAL-WHEN or during macroexpansion. + (restart-case (multiple-value-list (funcall function)) + (abort () :report "Abort compilation." (list nil)))))) + (destructuring-bind (successp &optional loadp faslfile) result + (let ((faslfile (etypecase faslfile + (null nil) + (pathname (pathname-to-filename faslfile))))) + (make-compilation-result :notes (reverse notes) + :duration seconds + :successp (if successp t) + :loadp (if loadp t) + :faslfile faslfile)))))) + +(defun swank-compile-file* (pathname load-p &rest options &key policy + &allow-other-keys) + (multiple-value-bind (output-pathname warnings? failure?) + (swank-compile-file pathname + (fasl-pathname pathname options) + nil + (or (guess-external-format pathname) + :default) + :policy policy) + (declare (ignore warnings?)) + (values t (not failure?) load-p output-pathname))) + +(defvar *compile-file-for-emacs-hook* '(swank-compile-file*)) + +(defslimefun compile-file-for-emacs (filename load-p &rest options) + "Compile FILENAME and, when LOAD-P, load the result. +Record compiler notes signalled as `compiler-condition's." + (with-buffer-syntax () + (collect-notes + (lambda () + (let ((pathname (filename-to-pathname filename)) + (*compile-print* nil) + (*compile-verbose* t)) + (loop for hook in *compile-file-for-emacs-hook* + do + (multiple-value-bind (tried success load? output-pathname) + (apply hook pathname load-p options) + (when tried + (return (values success load? output-pathname)))))))))) + +;; FIXME: now that *compile-file-for-emacs-hook* is there this is +;; redundant and confusing. +(defvar *fasl-pathname-function* nil + "In non-nil, use this function to compute the name for fasl-files.") + +(defun pathname-as-directory (pathname) + (append (pathname-directory pathname) + (when (pathname-name pathname) + (list (file-namestring pathname))))) + +(defun compile-file-output (file directory) + (make-pathname :directory (pathname-as-directory directory) + :defaults (compile-file-pathname file))) + +(defun fasl-pathname (input-file options) + (cond (*fasl-pathname-function* + (funcall *fasl-pathname-function* input-file options)) + ((getf options :fasl-directory) + (let ((dir (getf options :fasl-directory))) + (assert (char= (aref dir (1- (length dir))) #\/)) + (compile-file-output input-file dir))) + (t + (compile-file-pathname input-file)))) + +(defslimefun compile-string-for-emacs (string buffer position filename policy) + "Compile STRING (exerpted from BUFFER at POSITION). +Record compiler notes signalled as `compiler-condition's." + (let ((offset (cadr (assoc :position position)))) + (with-buffer-syntax () + (collect-notes + (lambda () + (let ((*compile-print* t) (*compile-verbose* nil)) + (swank-compile-string string + :buffer buffer + :position offset + :filename filename + :policy policy))))))) + +(defslimefun compile-multiple-strings-for-emacs (strings policy) + "Compile STRINGS (exerpted from BUFFER at POSITION). +Record compiler notes signalled as `compiler-condition's." + (loop for (string buffer package position filename) in strings collect + (collect-notes + (lambda () + (with-buffer-syntax (package) + (let ((*compile-print* t) (*compile-verbose* nil)) + (swank-compile-string string + :buffer buffer + :position position + :filename filename + :policy policy))))))) + +(defun file-newer-p (new-file old-file) + "Returns true if NEW-FILE is newer than OLD-FILE." + (> (file-write-date new-file) (file-write-date old-file))) + +(defun requires-compile-p (source-file) + (let ((fasl-file (probe-file (compile-file-pathname source-file)))) + (or (not fasl-file) + (file-newer-p source-file fasl-file)))) + +(defslimefun compile-file-if-needed (filename loadp) + (let ((pathname (filename-to-pathname filename))) + (cond ((requires-compile-p pathname) + (compile-file-for-emacs pathname loadp)) + (t + (collect-notes + (lambda () + (or (not loadp) + (load (compile-file-pathname pathname))))))))) + + +;;;; Loading + +(defslimefun load-file (filename) + (to-string (load (filename-to-pathname filename)))) + + +;;;;; swank-require + +(defslimefun swank-require (modules &optional filename) + "Load the module MODULE." + (dolist (module (ensure-list modules)) + (unless (member (string module) *modules* :test #'string=) + (require module (if filename + (filename-to-pathname filename) + (module-filename module))) + (assert (member (string module) *modules* :test #'string=) + () "Required module ~s was not provided" module))) + *modules*) + +(defvar *find-module* 'find-module + "Pluggable function to locate modules. +The function receives a module name as argument and should return +the filename of the module (or nil if the file doesn't exist).") + +(defun module-filename (module) + "Return the filename for the module MODULE." + (or (funcall *find-module* module) + (error "Can't locate module: ~s" module))) + +;;;;;; Simple *find-module* function. + +(defun merged-directory (dirname defaults) + (pathname-directory + (merge-pathnames + (make-pathname :directory `(:relative ,dirname) :defaults defaults) + defaults))) + +(defvar *load-path* '() + "A list of directories to search for modules.") + +(defun module-candidates (name dir) + (list (compile-file-pathname (make-pathname :name name :defaults dir)) + (make-pathname :name name :type "lisp" :defaults dir))) + +(defun find-module (module) + (let ((name (string-downcase module))) + (some (lambda (dir) (some #'probe-file (module-candidates name dir))) + *load-path*))) + + +;;;; Macroexpansion + +(defvar *macroexpand-printer-bindings* + '((*print-circle* . nil) + (*print-pretty* . t) + (*print-escape* . t) + (*print-lines* . nil) + (*print-level* . nil) + (*print-length* . nil))) + +(defun apply-macro-expander (expander string) + (with-buffer-syntax () + (with-bindings *macroexpand-printer-bindings* + (prin1-to-string (funcall expander (from-string string)))))) + +(defslimefun swank-macroexpand-1 (string) + (apply-macro-expander #'macroexpand-1 string)) + +(defslimefun swank-macroexpand (string) + (apply-macro-expander #'macroexpand string)) + +(defslimefun swank-macroexpand-all (string) + (apply-macro-expander #'macroexpand-all string)) + +(defslimefun swank-compiler-macroexpand-1 (string) + (apply-macro-expander #'compiler-macroexpand-1 string)) + +(defslimefun swank-compiler-macroexpand (string) + (apply-macro-expander #'compiler-macroexpand string)) + +(defslimefun swank-expand-1 (string) + (apply-macro-expander #'expand-1 string)) + +(defslimefun swank-expand (string) + (apply-macro-expander #'expand string)) + +(defun expand-1 (form) + (multiple-value-bind (expansion expanded?) (macroexpand-1 form) + (if expanded? + (values expansion t) + (compiler-macroexpand-1 form)))) + +(defun expand (form) + (expand-repeatedly #'expand-1 form)) + +(defun expand-repeatedly (expander form) + (loop + (multiple-value-bind (expansion expanded?) (funcall expander form) + (unless expanded? (return expansion)) + (setq form expansion)))) + +(defslimefun swank-format-string-expand (string) + (apply-macro-expander #'format-string-expand string)) + +(defslimefun disassemble-form (form) + (with-buffer-syntax () + (with-output-to-string (*standard-output*) + (let ((*print-readably* nil)) + (disassemble (eval (read-from-string form))))))) + + +;;;; Simple completion + +(defslimefun simple-completions (prefix package) + "Return a list of completions for the string PREFIX." + (let ((strings (all-completions prefix package))) + (list strings (longest-common-prefix strings)))) + +(defun all-completions (prefix package) + (multiple-value-bind (name pname intern) (tokenize-symbol prefix) + (let* ((extern (and pname (not intern))) + (pkg (cond ((equal pname "") keyword-package) + ((not pname) (guess-buffer-package package)) + (t (guess-package pname)))) + (test (lambda (sym) (prefix-match-p name (symbol-name sym)))) + (syms (and pkg (matching-symbols pkg extern test))) + (strings (loop for sym in syms + for str = (unparse-symbol sym) + when (prefix-match-p name str) ; remove |Foo| + collect str))) + (format-completion-set strings intern pname)))) + +(defun matching-symbols (package external test) + (let ((test (if external + (lambda (s) + (and (symbol-external-p s package) + (funcall test s))) + test)) + (result '())) + (do-symbols (s package) + (when (funcall test s) + (push s result))) + (remove-duplicates result))) + +(defun unparse-symbol (symbol) + (let ((*print-case* (case (readtable-case *readtable*) + (:downcase :upcase) + (t :downcase)))) + (unparse-name (symbol-name symbol)))) + +(defun prefix-match-p (prefix string) + "Return true if PREFIX is a prefix of STRING." + (not (mismatch prefix string :end2 (min (length string) (length prefix)) + :test #'char-equal))) + +(defun longest-common-prefix (strings) + "Return the longest string that is a common prefix of STRINGS." + (if (null strings) + "" + (flet ((common-prefix (s1 s2) + (let ((diff-pos (mismatch s1 s2))) + (if diff-pos (subseq s1 0 diff-pos) s1)))) + (reduce #'common-prefix strings)))) + +(defun format-completion-set (strings internal-p package-name) + "Format a set of completion strings. +Returns a list of completions with package qualifiers if needed." + (mapcar (lambda (string) (untokenize-symbol package-name internal-p string)) + (sort strings #'string<))) + + +;;;; Simple arglist display + +(defslimefun operator-arglist (name package) + (ignore-errors + (let ((args (arglist (parse-symbol name (guess-buffer-package package))))) + (cond ((eq args :not-available) nil) + (t (princ-to-string (cons name args))))))) + + +;;;; Documentation + +(defslimefun apropos-list-for-emacs (name &optional external-only + case-sensitive package) + "Make an apropos search for Emacs. +The result is a list of property lists." + (let ((package (if package + (or (parse-package package) + (error "No such package: ~S" package))))) + ;; The MAPCAN will filter all uninteresting symbols, i.e. those + ;; who cannot be meaningfully described. + (mapcan (listify #'briefly-describe-symbol-for-emacs) + (sort (remove-duplicates + (apropos-symbols name external-only case-sensitive package)) + #'present-symbol-before-p)))) + +(defun briefly-describe-symbol-for-emacs (symbol) + "Return a property list describing SYMBOL. +Like `describe-symbol-for-emacs' but with at most one line per item." + (flet ((first-line (string) + (let ((pos (position #\newline string))) + (if (null pos) string (subseq string 0 pos))))) + (let ((desc (map-if #'stringp #'first-line + (describe-symbol-for-emacs symbol)))) + (if desc + (list* :designator (to-string symbol) desc))))) + +(defun map-if (test fn &rest lists) + "Like (mapcar FN . LISTS) but only call FN on objects satisfying TEST. +Example: +\(map-if #'oddp #'- '(1 2 3 4 5)) => (-1 2 -3 4 -5)" + (apply #'mapcar + (lambda (x) (if (funcall test x) (funcall fn x) x)) + lists)) + +(defun listify (f) + "Return a function like F, but which returns any non-null value +wrapped in a list." + (lambda (x) + (let ((y (funcall f x))) + (and y (list y))))) + +(defun present-symbol-before-p (x y) + "Return true if X belongs before Y in a printed summary of symbols. +Sorted alphabetically by package name and then symbol name, except +that symbols accessible in the current package go first." + (declare (type symbol x y)) + (flet ((accessible (s) + ;; Test breaks on NIL for package that does not inherit it + (eq (find-symbol (symbol-name s) *buffer-package*) s))) + (let ((ax (accessible x)) (ay (accessible y))) + (cond ((and ax ay) (string< (symbol-name x) (symbol-name y))) + (ax t) + (ay nil) + (t (let ((px (symbol-package x)) (py (symbol-package y))) + (if (eq px py) + (string< (symbol-name x) (symbol-name y)) + (string< (package-name px) (package-name py))))))))) + +(defun make-apropos-matcher (pattern case-sensitive) + (let ((chr= (if case-sensitive #'char= #'char-equal))) + (lambda (symbol) + (search pattern (string symbol) :test chr=)))) + +(defun apropos-symbols (string external-only case-sensitive package) + (let ((packages (or package (remove (find-package :keyword) + (list-all-packages)))) + (matcher (make-apropos-matcher string case-sensitive)) + (result)) + (with-package-iterator (next packages :external :internal) + (loop (multiple-value-bind (morep symbol) (next) + (cond ((not morep) (return)) + ((and (if external-only (symbol-external-p symbol) t) + (funcall matcher symbol)) + (push symbol result)))))) + result)) + +(defun call-with-describe-settings (fn) + (let ((*print-readably* nil)) + (funcall fn))) + +(defmacro with-describe-settings ((&rest _) &body body) + (declare (ignore _)) + `(call-with-describe-settings (lambda () ,@body))) + +(defun describe-to-string (object) + (with-describe-settings () + (with-output-to-string (*standard-output*) + (describe object)))) + +(defslimefun describe-symbol (symbol-name) + (with-buffer-syntax () + (describe-to-string (parse-symbol-or-lose symbol-name)))) + +(defslimefun describe-function (name) + (with-buffer-syntax () + (let ((symbol (parse-symbol-or-lose name))) + (describe-to-string (or (macro-function symbol) + (symbol-function symbol)))))) + +(defslimefun describe-definition-for-emacs (name kind) + (with-buffer-syntax () + (with-describe-settings () + (with-output-to-string (*standard-output*) + (describe-definition (parse-symbol-or-lose name) kind))))) + +(defslimefun documentation-symbol (symbol-name) + (with-buffer-syntax () + (multiple-value-bind (sym foundp) (parse-symbol symbol-name) + (if foundp + (let ((vdoc (documentation sym 'variable)) + (fdoc (documentation sym 'function))) + (with-output-to-string (string) + (format string "Documentation for the symbol ~a:~2%" sym) + (unless (or vdoc fdoc) + (format string "Not documented." )) + (when vdoc + (format string "Variable:~% ~a~2%" vdoc)) + (when fdoc + (format string "Function:~% Arglist: ~a~2% ~a" + (arglist sym) + fdoc)))) + (format nil "No such symbol, ~a." symbol-name))))) + + +;;;; Package Commands + +(defslimefun list-all-package-names (&optional nicknames) + "Return a list of all package names. +Include the nicknames if NICKNAMES is true." + (mapcar #'unparse-name + (if nicknames + (mapcan #'package-names (list-all-packages)) + (mapcar #'package-name (list-all-packages))))) + + +;;;; Tracing + +;; Use eval for the sake of portability... +(defun tracedp (fspec) + (member fspec (eval '(trace)))) + +(defvar *after-toggle-trace-hook* nil + "Hook called whenever a SPEC is traced or untraced. + +If non-nil, called with two arguments SPEC and TRACED-P." ) +(defslimefun swank-toggle-trace (spec-string) + (let* ((spec (from-string spec-string)) + (retval (cond ((consp spec) ; handle complicated cases in the backend + (toggle-trace spec)) + ((tracedp spec) + (eval `(untrace ,spec)) + (format nil "~S is now untraced." spec)) + (t + (eval `(trace ,spec)) + (format nil "~S is now traced." spec)))) + (traced-p (let* ((tosearch "is now traced.") + (start (- (length retval) + (length tosearch))) + (end (+ start (length tosearch)))) + (search tosearch (subseq retval start end)))) + (hook-msg (when *after-toggle-trace-hook* + (funcall *after-toggle-trace-hook* + spec + traced-p)))) + (if hook-msg + (format nil "~a~%(also ~a)" retval hook-msg) + retval))) + +(defslimefun untrace-all () + (untrace)) + + +;;;; Undefing + +(defslimefun undefine-function (fname-string) + (let ((fname (from-string fname-string))) + (format nil "~S" (fmakunbound fname)))) + +(defslimefun unintern-symbol (name package) + (let ((pkg (guess-package package))) + (cond ((not pkg) (format nil "No such package: ~s" package)) + (t + (multiple-value-bind (sym found) (parse-symbol name pkg) + (case found + ((nil) (format nil "~s not in package ~s" name package)) + (t + (unintern sym pkg) + (format nil "Uninterned symbol: ~s" sym)))))))) + +(defslimefun swank-delete-package (package-name) + (let ((pkg (or (guess-package package-name) + (error "No such package: ~s" package-name)))) + (delete-package pkg) + nil)) + + +;;;; Profiling + +(defun profiledp (fspec) + (member fspec (profiled-functions))) + +(defslimefun toggle-profile-fdefinition (fname-string) + (let ((fname (from-string fname-string))) + (cond ((profiledp fname) + (unprofile fname) + (format nil "~S is now unprofiled." fname)) + (t + (profile fname) + (format nil "~S is now profiled." fname))))) + +(defslimefun profile-by-substring (substring package) + (let ((count 0)) + (flet ((maybe-profile (symbol) + (when (and (fboundp symbol) + (not (profiledp symbol)) + (search substring (symbol-name symbol) :test #'equalp)) + (handler-case (progn + (profile symbol) + (incf count)) + (error (condition) + (warn "~a" condition)))))) + (if package + (do-symbols (symbol (parse-package package)) + (maybe-profile symbol)) + (do-all-symbols (symbol) + (maybe-profile symbol)))) + (format nil "~a function~:p ~:*~[are~;is~:;are~] now profiled" count))) + +(defslimefun swank-profile-package (package-name callersp methodsp) + (let ((pkg (or (guess-package package-name) + (error "Not a valid package name: ~s" package-name)))) + (check-type callersp boolean) + (check-type methodsp boolean) + (profile-package pkg callersp methodsp))) + + +;;;; Source Locations + +(defslimefun find-definition-for-thing (thing) + (find-source-location thing)) + +(defslimefun find-source-location-for-emacs (spec) + (find-source-location (value-spec-ref spec))) + +(defun value-spec-ref (spec) + (dcase spec + ((:string string package) + (with-buffer-syntax (package) + (eval (read-from-string string)))) + ((:inspector part) + (inspector-nth-part part)) + ((:sldb frame var) + (frame-var-value frame var)))) + +(defvar *find-definitions-right-trim* ",:.>") +(defvar *find-definitions-left-trim* "#:<") + +(defun find-definitions-find-symbol-or-package (name) + (flet ((do-find (name) + (multiple-value-bind (symbol found name) + (with-buffer-syntax () + (parse-symbol name)) + (cond (found + (return-from find-definitions-find-symbol-or-package + (values symbol found))) + ;; Packages are not named by symbols, so + ;; not-interned symbols can refer to packages + ((find-package name) + (return-from find-definitions-find-symbol-or-package + (values (make-symbol name) t))))))) + (do-find name) + (do-find (string-right-trim *find-definitions-right-trim* name)) + (do-find (string-left-trim *find-definitions-left-trim* name)) + (do-find (string-left-trim *find-definitions-left-trim* + (string-right-trim + *find-definitions-right-trim* name))))) + +(defslimefun find-definitions-for-emacs (name) + "Return a list ((DSPEC LOCATION) ...) of definitions for NAME. +DSPEC is a string and LOCATION a source location. NAME is a string." + (multiple-value-bind (symbol found) + (find-definitions-find-symbol-or-package name) + (when found + (mapcar #'xref>elisp (find-definitions symbol))))) + +;;; Generic function so contribs can extend it. +(defgeneric xref-doit (type thing) + (:method (type thing) + (declare (ignore type thing)) + :not-implemented)) + +(macrolet ((define-xref-action (xref-type handler) + `(defmethod xref-doit ((type (eql ,xref-type)) thing) + (declare (ignorable type)) + (funcall ,handler thing)))) + (define-xref-action :calls #'who-calls) + (define-xref-action :calls-who #'calls-who) + (define-xref-action :references #'who-references) + (define-xref-action :binds #'who-binds) + (define-xref-action :sets #'who-sets) + (define-xref-action :macroexpands #'who-macroexpands) + (define-xref-action :specializes #'who-specializes) + (define-xref-action :callers #'list-callers) + (define-xref-action :callees #'list-callees)) + +(defslimefun xref (type name) + (multiple-value-bind (sexp error) (ignore-errors (from-string name)) + (unless error + (let ((xrefs (xref-doit type sexp))) + (if (eq xrefs :not-implemented) + :not-implemented + (mapcar #'xref>elisp xrefs)))))) + +(defslimefun xrefs (types name) + (loop for type in types + for xrefs = (xref type name) + when (and (not (eq :not-implemented xrefs)) + (not (null xrefs))) + collect (cons type xrefs))) + +(defun xref>elisp (xref) + (destructuring-bind (name loc) xref + (list (to-string name) loc))) + + +;;;;; Lazy lists + +(defstruct (lcons (:constructor %lcons (car %cdr)) + (:predicate lcons?)) + car + (%cdr nil :type (or null lcons function)) + (forced? nil)) + +(defmacro lcons (car cdr) + `(%lcons ,car (lambda () ,cdr))) + +(defmacro lcons* (car cdr &rest more) + (cond ((null more) `(lcons ,car ,cdr)) + (t `(lcons ,car (lcons* ,cdr ,@more))))) + +(defun lcons-cdr (lcons) + (with-struct* (lcons- @ lcons) + (cond ((@ forced?) + (@ %cdr)) + (t + (let ((value (funcall (@ %cdr)))) + (setf (@ forced?) t + (@ %cdr) value)))))) + +(defun llist-range (llist start end) + (llist-take (llist-skip llist start) (- end start))) + +(defun llist-skip (lcons index) + (do ((i 0 (1+ i)) + (l lcons (lcons-cdr l))) + ((or (= i index) (null l)) + l))) + +(defun llist-take (lcons count) + (let ((result '())) + (do ((i 0 (1+ i)) + (l lcons (lcons-cdr l))) + ((or (= i count) + (null l))) + (push (lcons-car l) result)) + (nreverse result))) + +(defun iline (label value) + `(:line ,label ,value)) + + +;;;; Inspecting + +(defvar *inspector-verbose* nil) + +(defvar *inspector-printer-bindings* + '((*print-lines* . 1) + (*print-right-margin* . 75) + (*print-pretty* . t) + (*print-readably* . nil))) + +(defvar *inspector-verbose-printer-bindings* + '((*print-escape* . t) + (*print-circle* . t) + (*print-array* . nil))) + +(defstruct inspector-state) +(defstruct (istate (:conc-name istate.) (:include inspector-state)) + object + (verbose *inspector-verbose*) + (parts (make-array 10 :adjustable t :fill-pointer 0)) + (actions (make-array 10 :adjustable t :fill-pointer 0)) + metadata-plist + content + next previous) + +(defvar *istate* nil) +(defvar *inspector-history*) + +(defun reset-inspector () + (setq *istate* nil + *inspector-history* (make-array 10 :adjustable t :fill-pointer 0))) + +(defslimefun init-inspector (string) + (with-buffer-syntax () + (with-retry-restart (:msg "Retry SLIME inspection request.") + (reset-inspector) + (inspect-object (eval (read-from-string string)))))) + +(defun ensure-istate-metadata (o indicator default) + (with-struct (istate. object metadata-plist) *istate* + (assert (eq object o)) + (let ((data (getf metadata-plist indicator default))) + (setf (getf metadata-plist indicator) data) + data))) + +(defun inspect-object (o) + (let* ((prev *istate*) + (istate (make-istate :object o :previous prev + :verbose (cond (prev (istate.verbose prev)) + (t *inspector-verbose*))))) + (setq *istate* istate) + (setf (istate.content istate) (emacs-inspect/istate istate)) + (unless (find o *inspector-history*) + (vector-push-extend o *inspector-history*)) + (let ((previous (istate.previous istate))) + (if previous (setf (istate.next previous) istate))) + (istate>elisp istate))) + +(defun emacs-inspect/istate (istate) + (with-bindings (if (istate.verbose istate) + *inspector-verbose-printer-bindings* + *inspector-printer-bindings*) + (emacs-inspect (istate.object istate)))) + +(defun istate>elisp (istate) + (list :title (prepare-title istate) + :id (assign-index (istate.object istate) (istate.parts istate)) + :content (prepare-range istate 0 500))) + +(defun prepare-title (istate) + (if (istate.verbose istate) + (with-bindings *inspector-verbose-printer-bindings* + (to-string (istate.object istate))) + (with-string-stream (stream :length 200 + :bindings *inspector-printer-bindings*) + (print-unreadable-object + ((istate.object istate) stream :type t :identity t))))) + +(defun prepare-range (istate start end) + (let* ((range (content-range (istate.content istate) start end)) + (ps (loop for part in range append (prepare-part part istate)))) + (list ps + (if (< (length ps) (- end start)) + (+ start (length ps)) + (+ end 1000)) + start end))) + +(defun prepare-part (part istate) + (let ((newline '#.(string #\newline))) + (etypecase part + (string (list part)) + (cons (dcase part + ((:newline) (list newline)) + ((:value obj &optional str) + (list (value-part obj str (istate.parts istate)))) + ((:label &rest strs) + (list (list :label (apply #'cat (mapcar #'string strs))))) + ((:action label lambda &key (refreshp t)) + (list (action-part label lambda refreshp + (istate.actions istate)))) + ((:line label value) + (list (princ-to-string label) ": " + (value-part value nil (istate.parts istate)) + newline))))))) + +(defun value-part (object string parts) + (list :value + (or string (print-part-to-string object)) + (assign-index object parts))) + +(defun action-part (label lambda refreshp actions) + (list :action label (assign-index (list lambda refreshp) actions))) + +(defun assign-index (object vector) + (let ((index (fill-pointer vector))) + (vector-push-extend object vector) + index)) + +(defun print-part-to-string (value) + (let* ((*print-readably* nil) + (string (to-line value)) + (pos (position value *inspector-history*))) + (if pos + (format nil "@~D=~A" pos string) + string))) + +(defun content-range (list start end) + (typecase list + (list (let ((len (length list))) + (subseq list start (min len end)))) + (lcons (llist-range list start end)))) + +(defslimefun inspector-nth-part (index) + "Return the current inspector's INDEXth part. +The second value indicates if that part exists at all." + (let* ((parts (istate.parts *istate*)) + (foundp (< index (length parts)))) + (values (and foundp (aref parts index)) + foundp))) + +(defslimefun inspect-nth-part (index) + (with-buffer-syntax () + (inspect-object (inspector-nth-part index)))) + +(defslimefun inspector-range (from to) + (prepare-range *istate* from to)) + +(defslimefun inspector-call-nth-action (index &rest args) + (destructuring-bind (fun refreshp) (aref (istate.actions *istate*) index) + (apply fun args) + (if refreshp + (inspector-reinspect) + ;; tell emacs that we don't want to refresh the inspector buffer + nil))) + +(defslimefun inspector-pop () + "Inspect the previous object. +Return nil if there's no previous object." + (with-buffer-syntax () + (cond ((istate.previous *istate*) + (setq *istate* (istate.previous *istate*)) + (istate>elisp *istate*)) + (t nil)))) + +(defslimefun inspector-next () + "Inspect the next element in the history of inspected objects.." + (with-buffer-syntax () + (cond ((istate.next *istate*) + (setq *istate* (istate.next *istate*)) + (istate>elisp *istate*)) + (t nil)))) + +(defslimefun inspector-reinspect () + (let ((istate *istate*)) + (setf (istate.content istate) (emacs-inspect/istate istate)) + (istate>elisp istate))) + +(defslimefun inspector-toggle-verbose () + "Toggle verbosity of inspected object." + (setf (istate.verbose *istate*) (not (istate.verbose *istate*))) + (istate>elisp *istate*)) + +(defslimefun inspector-eval (string) + (let* ((obj (istate.object *istate*)) + (context (eval-context obj)) + (form (with-buffer-syntax ((cdr (assoc '*package* context))) + (read-from-string string))) + (ignorable (remove-if #'boundp (mapcar #'car context)))) + (to-string (eval `(let ((* ',obj) (- ',form) + . ,(loop for (var . val) in context + unless (constantp var) collect + `(,var ',val))) + (declare (ignorable . ,ignorable)) + ,form))))) + +(defslimefun inspector-history () + (with-output-to-string (out) + (let ((newest (loop for s = *istate* then next + for next = (istate.next s) + if (not next) return s))) + (format out "--- next/prev chain ---") + (loop for s = newest then (istate.previous s) while s do + (let ((val (istate.object s))) + (format out "~%~:[ ~; *~]@~d " + (eq s *istate*) + (position val *inspector-history*)) + (print-unreadable-object (val out :type t :identity t))))) + (format out "~%~%--- all visited objects ---") + (loop for val across *inspector-history* for i from 0 do + (format out "~%~2,' d " i) + (print-unreadable-object (val out :type t :identity t))))) + +(defslimefun quit-inspector () + (reset-inspector) + nil) + +(defslimefun describe-inspectee () + "Describe the currently inspected object." + (with-buffer-syntax () + (describe-to-string (istate.object *istate*)))) + +(defslimefun pprint-inspector-part (index) + "Pretty-print the currently inspected object." + (with-buffer-syntax () + (swank-pprint (list (inspector-nth-part index))))) + +(defslimefun inspect-in-frame (string index) + (with-buffer-syntax () + (with-retry-restart (:msg "Retry SLIME inspection request.") + (reset-inspector) + (inspect-object (eval-in-frame (from-string string) index))))) + +(defslimefun inspect-current-condition () + (with-buffer-syntax () + (reset-inspector) + (inspect-object *swank-debugger-condition*))) + +(defslimefun inspect-frame-var (frame var) + (with-buffer-syntax () + (reset-inspector) + (inspect-object (frame-var-value frame var)))) + +;;;;; Lists + +(defmethod emacs-inspect ((o cons)) + (if (listp (cdr o)) + (inspect-list o) + (inspect-cons o))) + +(defun inspect-cons (cons) + (label-value-line* + ('car (car cons)) + ('cdr (cdr cons)))) + +(defun inspect-list (list) + (multiple-value-bind (length tail) (safe-length list) + (flet ((frob (title list) + (list* title '(:newline) (inspect-list-aux list)))) + (cond ((not length) + (frob "A circular list:" + (cons (car list) + (ldiff (cdr list) list)))) + ((not tail) + (frob "A proper list:" list)) + (t + (frob "An improper list:" list)))))) + +(defun inspect-list-aux (list) + (loop for i from 0 for rest on list while (consp rest) append + (if (listp (cdr rest)) + (label-value-line i (car rest)) + (label-value-line* (i (car rest)) (:tail (cdr rest)))))) + +(defun safe-length (list) + "Similar to `list-length', but avoid errors on improper lists. +Return two values: the length of the list and the last cdr. +Return NIL if LIST is circular." + (do ((n 0 (+ n 2)) ;Counter. + (fast list (cddr fast)) ;Fast pointer: leaps by 2. + (slow list (cdr slow))) ;Slow pointer: leaps by 1. + (nil) + (cond ((null fast) (return (values n nil))) + ((not (consp fast)) (return (values n fast))) + ((null (cdr fast)) (return (values (1+ n) (cdr fast)))) + ((and (eq fast slow) (> n 0)) (return nil)) + ((not (consp (cdr fast))) (return (values (1+ n) (cdr fast))))))) + +;;;;; Hashtables + +(defun hash-table-to-alist (ht) + (let ((result '())) + (maphash (lambda (key value) + (setq result (acons key value result))) + ht) + result)) + +(defmethod emacs-inspect ((ht hash-table)) + (append + (label-value-line* + ("Count" (hash-table-count ht)) + ("Size" (hash-table-size ht)) + ("Test" (hash-table-test ht)) + ("Rehash size" (hash-table-rehash-size ht)) + ("Rehash threshold" (hash-table-rehash-threshold ht))) + (let ((weakness (hash-table-weakness ht))) + (when weakness + (label-value-line "Weakness:" weakness))) + (unless (zerop (hash-table-count ht)) + `((:action "[clear hashtable]" + ,(lambda () (clrhash ht))) (:newline) + "Contents: " (:newline))) + (let ((content (hash-table-to-alist ht))) + (cond ((every (lambda (x) (typep (first x) '(or string symbol))) content) + (setf content (sort content 'string< :key #'first))) + ((every (lambda (x) (typep (first x) 'number)) content) + (setf content (sort content '< :key #'first)))) + (loop for (key . value) in content appending + `((:value ,key) " = " (:value ,value) + " " (:action "[remove entry]" + ,(let ((key key)) + (lambda () (remhash key ht)))) + (:newline)))))) + +;;;;; Arrays + +(defmethod emacs-inspect ((array array)) + (lcons* + (iline "Dimensions" (array-dimensions array)) + (iline "Element type" (array-element-type array)) + (iline "Total size" (array-total-size array)) + (iline "Adjustable" (adjustable-array-p array)) + (iline "Fill pointer" (if (array-has-fill-pointer-p array) + (fill-pointer array))) + "Contents:" '(:newline) + (labels ((k (i max) + (cond ((= i max) '()) + (t (lcons (iline i (row-major-aref array i)) + (k (1+ i) max)))))) + (k 0 (array-total-size array))))) + +;;;;; Chars + +(defmethod emacs-inspect ((char character)) + (append + (label-value-line* + ("Char code" (char-code char)) + ("Lower cased" (char-downcase char)) + ("Upper cased" (char-upcase char))) + (if (get-macro-character char) + `("In the current readtable (" + (:value ,*readtable*) ") it is a macro character: " + (:value ,(get-macro-character char)))))) + +;;;; Thread listing + +(defvar *thread-list* () + "List of threads displayed in Emacs. We don't care a about +synchronization issues (yet). There can only be one thread listing at +a time.") + +(defslimefun list-threads () + "Return a list (LABELS (ID NAME STATUS ATTRS ...) ...). +LABELS is a list of attribute names and the remaining lists are the +corresponding attribute values per thread. +Example: + ((:id :name :status :priority) + (6 \"swank-indentation-cache-thread\" \"Semaphore timed wait\" 0) + (5 \"reader-thread\" \"Active\" 0) + (4 \"control-thread\" \"Semaphore timed wait\" 0) + (2 \"Swank Sentinel\" \"Semaphore timed wait\" 0) + (1 \"listener\" \"Active\" 0) + (0 \"Initial\" \"Sleep\" 0))" + (setq *thread-list* (all-threads)) + (when (and *emacs-connection* + (use-threads-p) + (equalp (thread-name (current-thread)) "worker")) + (setf *thread-list* (delete (current-thread) *thread-list*))) + (let* ((plist (thread-attributes (car *thread-list*))) + (labels (loop for (key) on plist by #'cddr + collect key))) + `((:id :name :status ,@labels) + ,@(loop for thread in *thread-list* + for name = (thread-name thread) + for attributes = (thread-attributes thread) + collect (list* (thread-id thread) + (string name) + (thread-status thread) + (loop for label in labels + collect (getf attributes label))))))) + +(defslimefun quit-thread-browser () + (setq *thread-list* nil)) + +(defun nth-thread (index) + (nth index *thread-list*)) + +(defslimefun debug-nth-thread (index) + (let ((connection *emacs-connection*)) + (interrupt-thread (nth-thread index) + (lambda () + (invoke-or-queue-interrupt + (lambda () + (with-connection (connection) + (simple-break)))))))) + +(defslimefun kill-nth-thread (index) + (kill-thread (nth-thread index))) + +(defslimefun start-swank-server-in-thread (index port-file-name) + "Interrupt the INDEXth thread and make it start a swank server. +The server port is written to PORT-FILE-NAME." + (interrupt-thread (nth-thread index) + (lambda () + (start-server port-file-name :style nil)))) + +;;;; Class browser + +(defun mop-helper (class-name fn) + (let ((class (find-class class-name nil))) + (if class + (mapcar (lambda (x) (to-string (class-name x))) + (funcall fn class))))) + +(defslimefun mop (type symbol-name) + "Return info about classes using mop. + + When type is: + :subclasses - return the list of subclasses of class. + :superclasses - return the list of superclasses of class." + (let ((symbol (parse-symbol symbol-name *buffer-package*))) + (ecase type + (:subclasses + (mop-helper symbol #'swank-mop:class-direct-subclasses)) + (:superclasses + (mop-helper symbol #'swank-mop:class-direct-superclasses))))) + + +;;;; Automatically synchronized state +;;; +;;; Here we add hooks to push updates of relevant information to +;;; Emacs. + +;;;;; *FEATURES* + +(defun sync-features-to-emacs () + "Update Emacs if any relevant Lisp state has changed." + ;; FIXME: *slime-features* should be connection-local + (unless (eq *slime-features* *features*) + (setq *slime-features* *features*) + (send-to-emacs (list :new-features (features-for-emacs))))) + +(defun features-for-emacs () + "Return `*slime-features*' in a format suitable to send it to Emacs." + *slime-features*) + +(add-hook *pre-reply-hook* 'sync-features-to-emacs) + + +;;;;; Indentation of macros +;;; +;;; This code decides how macros should be indented (based on their +;;; arglists) and tells Emacs. A per-connection cache is used to avoid +;;; sending redundant information to Emacs -- we just say what's +;;; changed since last time. +;;; +;;; The strategy is to scan all symbols, pick out the macros, and look +;;; for &body-arguments. + +(defvar *configure-emacs-indentation* t + "When true, automatically send indentation information to Emacs +after each command.") + +(defslimefun update-indentation-information () + (send-to-indentation-cache `(:update-indentation-information)) + nil) + +;; This function is for *PRE-REPLY-HOOK*. +(defun sync-indentation-to-emacs () + "Send any indentation updates to Emacs via CONNECTION." + (when *configure-emacs-indentation* + (send-to-indentation-cache `(:sync-indentation ,*buffer-package*)))) + +;; Send REQUEST to the cache. If we are single threaded perform the +;; request right away, otherwise delegate the request to the +;; indentation-cache-thread. +(defun send-to-indentation-cache (request) + (let ((c *emacs-connection*)) + (etypecase c + (singlethreaded-connection + (handle-indentation-cache-request c request)) + (multithreaded-connection + (without-slime-interrupts + (send (mconn.indentation-cache-thread c) request)))))) + +(defun indentation-cache-loop (connection) + (with-connection (connection) + (loop + (restart-case + (handle-indentation-cache-request connection (receive)) + (abort () + :report "Return to the indentation cache request handling loop."))))) + +(defun handle-indentation-cache-request (connection request) + (dcase request + ((:sync-indentation package) + (let ((fullp (need-full-indentation-update-p connection))) + (perform-indentation-update connection fullp package))) + ((:update-indentation-information) + (perform-indentation-update connection t nil)))) + +(defun need-full-indentation-update-p (connection) + "Return true if the whole indentation cache should be updated. +This is a heuristic to avoid scanning all symbols all the time: +instead, we only do a full scan if the set of packages has changed." + (set-difference (list-all-packages) + (connection.indentation-cache-packages connection))) + +(defun perform-indentation-update (connection force package) + "Update the indentation cache in CONNECTION and update Emacs. +If FORCE is true then start again without considering the old cache." + (let ((cache (connection.indentation-cache connection))) + (when force (clrhash cache)) + (let ((delta (update-indentation/delta-for-emacs cache force package))) + (setf (connection.indentation-cache-packages connection) + (list-all-packages)) + (unless (null delta) + (setf (connection.indentation-cache connection) cache) + (send-to-emacs (list :indentation-update delta)))))) + +(defun update-indentation/delta-for-emacs (cache force package) + "Update the cache and return the changes in a (SYMBOL INDENT PACKAGES) list. +If FORCE is true then check all symbols, otherwise only check symbols +belonging to PACKAGE." + (let ((alist '())) + (flet ((consider (symbol) + (let ((indent (symbol-indentation symbol))) + (when indent + (unless (equal (gethash symbol cache) indent) + (setf (gethash symbol cache) indent) + (let ((pkgs (mapcar #'package-name + (symbol-packages symbol))) + (name (string-downcase symbol))) + (push (list name indent pkgs) alist))))))) + (cond (force + (do-all-symbols (symbol) + (consider symbol))) + ((package-name package) ; don't try to iterate over a + ; deleted package. + (do-symbols (symbol package) + (when (eq (symbol-package symbol) package) + (consider symbol))))) + alist))) + +(defun package-names (package) + "Return the name and all nicknames of PACKAGE in a fresh list." + (cons (package-name package) (copy-list (package-nicknames package)))) + +(defun symbol-packages (symbol) + "Return the packages where SYMBOL can be found." + (let ((string (string symbol))) + (loop for p in (list-all-packages) + when (eq symbol (find-symbol string p)) + collect p))) + +(defun cl-symbol-p (symbol) + "Is SYMBOL a symbol in the COMMON-LISP package?" + (eq (symbol-package symbol) cl-package)) + +(defun known-to-emacs-p (symbol) + "Return true if Emacs has special rules for indenting SYMBOL." + (cl-symbol-p symbol)) + +(defun symbol-indentation (symbol) + "Return a form describing the indentation of SYMBOL. +The form is to be used as the `common-lisp-indent-function' property +in Emacs." + (if (and (macro-function symbol) + (not (known-to-emacs-p symbol))) + (let ((arglist (arglist symbol))) + (etypecase arglist + ((member :not-available) + nil) + (list + (macro-indentation arglist)))) + nil)) + +(defun macro-indentation (arglist) + (if (well-formed-list-p arglist) + (position '&body (remove '&optional (clean-arglist arglist))) + nil)) + +(defun clean-arglist (arglist) + "Remove &whole, &enviroment, and &aux elements from ARGLIST." + (cond ((null arglist) '()) + ((member (car arglist) '(&whole &environment)) + (clean-arglist (cddr arglist))) + ((eq (car arglist) '&aux) + '()) + (t (cons (car arglist) (clean-arglist (cdr arglist)))))) + +(defun well-formed-list-p (list) + "Is LIST a proper list terminated by NIL?" + (typecase list + (null t) + (cons (well-formed-list-p (cdr list))) + (t nil))) + +(defun print-indentation-lossage (&optional (stream *standard-output*)) + "Return the list of symbols whose indentation styles collide incompatibly. +Collisions are caused because package information is ignored." + (let ((table (make-hash-table :test 'equal))) + (flet ((name (s) (string-downcase (symbol-name s)))) + (do-all-symbols (s) + (setf (gethash (name s) table) + (cons s (symbol-indentation s)))) + (let ((collisions '())) + (do-all-symbols (s) + (let* ((entry (gethash (name s) table)) + (owner (car entry)) + (indent (cdr entry))) + (unless (or (eq s owner) + (equal (symbol-indentation s) indent) + (and (not (fboundp s)) + (null (macro-function s)))) + (pushnew owner collisions) + (pushnew s collisions)))) + (if (null collisions) + (format stream "~&No worries!~%") + (format stream "~&Symbols with collisions:~%~{ ~S~%~}" + collisions)))))) + +;;; FIXME: it's too slow on CLASP right now, remove once it's fast enough. +#-clasp +(add-hook *pre-reply-hook* 'sync-indentation-to-emacs) + + +;;;; Testing + +(defslimefun io-speed-test (&optional (n 1000) (m 1)) + (let* ((s *standard-output*) + (*trace-output* (make-broadcast-stream s *log-output*))) + (time (progn + (dotimes (i n) + (format s "~D abcdefghijklm~%" i) + (when (zerop (mod n m)) + (finish-output s))) + (finish-output s) + (when *emacs-connection* + (eval-in-emacs '(message "done."))))) + (terpri *trace-output*) + (finish-output *trace-output*) + nil)) + +(defslimefun flow-control-test (n delay) + (let ((stream (make-output-stream + (let ((conn *emacs-connection*)) + (lambda (string) + (declare (ignore string)) + (with-connection (conn) + (send-to-emacs `(:test-delay ,delay)))))))) + (dotimes (i n) + (print i stream) + (force-output stream) + (background-message "flow-control-test: ~d" i)))) + + +(defun before-init (version load-path) + (pushnew :swank *features*) + (setq *swank-wire-protocol-version* version) + (setq *load-path* load-path)) + +(defun init () + (run-hook *after-init-hook*)) + +;; Local Variables: +;; coding: latin-1-unix +;; indent-tabs-mode: nil +;; outline-regexp: ";;;;;*" +;; End: + +;;; swank.lisp ends here diff --git a/vim/bundle/slimv/slime/swank/abcl.lisp b/vim/bundle/slimv/slime/swank/abcl.lisp new file mode 100644 index 0000000..f5764d6 --- /dev/null +++ b/vim/bundle/slimv/slime/swank/abcl.lisp @@ -0,0 +1,847 @@ +;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*- +;;; +;;; swank-abcl.lisp --- Armedbear CL specific code for SLIME. +;;; +;;; Adapted from swank-acl.lisp, Andras Simon, 2004 +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(defpackage swank/abcl + (:use cl swank/backend)) + +(in-package swank/abcl) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :collect) ;just so that it doesn't spoil the flying letters + (require :pprint) + (require :gray-streams) + (assert (>= (read-from-string (subseq (lisp-implementation-version) 0 4)) + 0.22) + () "This file needs ABCL version 0.22 or newer")) + +(defimplementation gray-package-name () + "GRAY-STREAMS") + +;; FIXME: switch to shared Gray stream implementation when bugs are +;; fixed in ABCL. See: http://abcl.org/trac/ticket/373. +(progn + (defimplementation make-output-stream (write-string) + (ext:make-slime-output-stream write-string)) + + (defimplementation make-input-stream (read-string) + (ext:make-slime-input-stream read-string + (make-synonym-stream '*standard-output*)))) + +(defimplementation call-with-compilation-hooks (function) + (funcall function)) + +;;; swank-mop + +;;dummies and definition + +(defclass standard-slot-definition ()()) + +;(defun class-finalized-p (class) t) + +(defun slot-definition-documentation (slot) + (declare (ignore slot)) + #+nil (documentation slot 't)) + +(defun slot-definition-type (slot) + (declare (ignore slot)) + t) + +(defun class-prototype (class) + (declare (ignore class)) + nil) + +(defun generic-function-declarations (gf) + (declare (ignore gf)) + nil) + +(defun specializer-direct-methods (spec) + (mop:class-direct-methods spec)) + +(defun slot-definition-name (slot) + (mop:slot-definition-name slot)) + +(defun class-slots (class) + (mop:class-slots class)) + +(defun method-generic-function (method) + (mop:method-generic-function method)) + +(defun method-function (method) + (mop:method-function method)) + +(defun slot-boundp-using-class (class object slotdef) + (declare (ignore class)) + (system::slot-boundp object (slot-definition-name slotdef))) + +(defun slot-value-using-class (class object slotdef) + (declare (ignore class)) + (system::slot-value object (slot-definition-name slotdef))) + +(import-to-swank-mop + '( ;; classes + cl:standard-generic-function + standard-slot-definition ;;dummy + cl:method + cl:standard-class + #+#.(swank/backend:with-symbol 'compute-applicable-methods-using-classes + 'mop) + mop:compute-applicable-methods-using-classes + ;; standard-class readers + mop:class-default-initargs + mop:class-direct-default-initargs + mop:class-direct-slots + mop:class-direct-subclasses + mop:class-direct-superclasses + mop:eql-specializer + mop:class-finalized-p + mop:finalize-inheritance + cl:class-name + mop:class-precedence-list + class-prototype ;;dummy + class-slots + specializer-direct-methods + ;; eql-specializer accessors + mop::eql-specializer-object + ;; generic function readers + mop:generic-function-argument-precedence-order + generic-function-declarations ;;dummy + mop:generic-function-lambda-list + mop:generic-function-methods + mop:generic-function-method-class + mop:generic-function-method-combination + mop:generic-function-name + ;; method readers + method-generic-function + method-function + mop:method-lambda-list + mop:method-specializers + mop:method-qualifiers + ;; slot readers + mop:slot-definition-allocation + slot-definition-documentation ;;dummy + mop:slot-definition-initargs + mop:slot-definition-initform + mop:slot-definition-initfunction + slot-definition-name + slot-definition-type ;;dummy + mop:slot-definition-readers + mop:slot-definition-writers + slot-boundp-using-class + slot-value-using-class + mop:slot-makunbound-using-class)) + +;;;; TCP Server + + +(defimplementation preferred-communication-style () + :spawn) + +(defimplementation create-socket (host port &key backlog) + (ext:make-server-socket port)) + +(defimplementation local-port (socket) + (java:jcall (java:jmethod "java.net.ServerSocket" "getLocalPort") socket)) + +(defimplementation close-socket (socket) + (ext:server-socket-close socket)) + +(defimplementation accept-connection (socket + &key external-format buffering timeout) + (declare (ignore buffering timeout)) + (ext:get-socket-stream (ext:socket-accept socket) + :element-type (if external-format + 'character + '(unsigned-byte 8)) + :external-format (or external-format :default))) + +;;;; UTF8 + +;; faster please! +(defimplementation string-to-utf8 (s) + (jbytes-to-octets + (java:jcall + (java:jmethod "java.lang.String" "getBytes" "java.lang.String") + s + "UTF8"))) + +(defimplementation utf8-to-string (u) + (java:jnew + (java:jconstructor "org.armedbear.lisp.SimpleString" + "java.lang.String") + (java:jnew (java:jconstructor "java.lang.String" "[B" "java.lang.String") + (octets-to-jbytes u) + "UTF8"))) + +(defun octets-to-jbytes (octets) + (declare (type octets (simple-array (unsigned-byte 8) (*)))) + (let* ((len (length octets)) + (bytes (java:jnew-array "byte" len))) + (loop for byte across octets + for i from 0 + do (java:jstatic (java:jmethod "java.lang.reflect.Array" "setByte" + "java.lang.Object" "int" "byte") + "java.lang.relect.Array" + bytes i byte)) + bytes)) + +(defun jbytes-to-octets (jbytes) + (let* ((len (java:jarray-length jbytes)) + (octets (make-array len :element-type '(unsigned-byte 8)))) + (loop for i from 0 below len + for jbyte = (java:jarray-ref jbytes i) + do (setf (aref octets i) jbyte)) + octets)) + +;;;; External formats + +(defvar *external-format-to-coding-system* + '((:iso-8859-1 "latin-1" "iso-latin-1" "iso-8859-1") + ((:iso-8859-1 :eol-style :lf) + "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix") + (:utf-8 "utf-8") + ((:utf-8 :eol-style :lf) "utf-8-unix") + (:euc-jp "euc-jp") + ((:euc-jp :eol-style :lf) "euc-jp-unix") + (:us-ascii "us-ascii") + ((:us-ascii :eol-style :lf) "us-ascii-unix"))) + +(defimplementation find-external-format (coding-system) + (car (rassoc-if (lambda (x) + (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + +;;;; Unix signals + +(defimplementation getpid () + (handler-case + (let* ((runtime + (java:jstatic "getRuntime" "java.lang.Runtime")) + (command + (java:jnew-array-from-array + "java.lang.String" #("sh" "-c" "echo $PPID"))) + (runtime-exec-jmethod + ;; Complicated because java.lang.Runtime.exec() is + ;; overloaded on a non-primitive type (array of + ;; java.lang.String), so we have to use the actual + ;; parameter instance to get java.lang.Class + (java:jmethod "java.lang.Runtime" "exec" + (java:jcall + (java:jmethod "java.lang.Object" "getClass") + command))) + (process + (java:jcall runtime-exec-jmethod runtime command)) + (output + (java:jcall (java:jmethod "java.lang.Process" "getInputStream") + process))) + (java:jcall (java:jmethod "java.lang.Process" "waitFor") + process) + (loop :with b :do + (setq b + (java:jcall (java:jmethod "java.io.InputStream" "read") + output)) + :until (member b '(-1 #x0a)) ; Either EOF or LF + :collecting (code-char b) :into result + :finally (return + (parse-integer (coerce result 'string))))) + (t () 0))) + +(defimplementation lisp-implementation-type-name () + "armedbear") + +(defimplementation set-default-directory (directory) + (let ((dir (sys::probe-directory directory))) + (when dir (setf *default-pathname-defaults* dir)) + (namestring dir))) + + +;;;; Misc + +(defimplementation arglist (fun) + (cond ((symbolp fun) + (multiple-value-bind (arglist present) + (sys::arglist fun) + (when (and (not present) + (fboundp fun) + (typep (symbol-function fun) + 'standard-generic-function)) + (setq arglist + (mop::generic-function-lambda-list (symbol-function fun)) + present + t)) + (if present arglist :not-available))) + (t :not-available))) + +(defimplementation function-name (function) + (nth-value 2 (function-lambda-expression function))) + +(defimplementation macroexpand-all (form &optional env) + (ext:macroexpand-all form env)) + +(defimplementation collect-macro-forms (form &optional env) + ;; Currently detects only normal macros, not compiler macros. + (declare (ignore env)) + (with-collected-macro-forms (macro-forms) + (handler-bind ((warning #'muffle-warning)) + (ignore-errors + (compile nil `(lambda () ,(macroexpand-all form env))))) + (values macro-forms nil))) + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind &optional (sym symbol)) + (or (documentation sym kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (when (boundp symbol) + (doc 'variable))) + (when (fboundp symbol) + (maybe-push + (cond ((macro-function symbol) :macro) + ((special-operator-p symbol) :special-operator) + ((typep (fdefinition symbol) 'generic-function) + :generic-function) + (t :function)) + (doc 'function))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + result))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + ((:variable :macro) + (describe symbol)) + ((:function :generic-function) + (describe (symbol-function symbol))) + (:class + (describe (find-class symbol))))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + (:variable + (describe symbol)) + ((:function :generic-function) + (describe (symbol-function symbol))) + (:class + (describe (find-class symbol))))) + + +;;;; Debugger + +;; Copied from swank-sbcl.lisp. +;; +;; Notice that *INVOKE-DEBUGGER-HOOK* is tried before *DEBUGGER-HOOK*, +;; so we have to make sure that the latter gets run when it was +;; established locally by a user (i.e. changed meanwhile.) +(defun make-invoke-debugger-hook (hook) + (lambda (condition old-hook) + (if *debugger-hook* + (funcall *debugger-hook* condition old-hook) + (funcall hook condition old-hook)))) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook) + (sys::*invoke-debugger-hook* (make-invoke-debugger-hook hook))) + (funcall fun))) + +(defimplementation install-debugger-globally (function) + (setq *debugger-hook* function) + (setq sys::*invoke-debugger-hook* (make-invoke-debugger-hook function))) + +(defvar *sldb-topframe*) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (let* ((magic-token (intern "SWANK-DEBUGGER-HOOK" 'swank)) + (*sldb-topframe* + (second (member magic-token (sys:backtrace) + :key (lambda (frame) + (first (sys:frame-to-list frame))))))) + (funcall debugger-loop-fn))) + +(defun backtrace (start end) + "A backtrace without initial SWANK frames." + (let ((backtrace (sys:backtrace))) + (subseq (or (member *sldb-topframe* backtrace) backtrace) + start end))) + +(defun nth-frame (index) + (nth index (backtrace 0 nil))) + +(defimplementation compute-backtrace (start end) + (let ((end (or end most-positive-fixnum))) + (backtrace start end))) + +(defimplementation print-frame (frame stream) + (write-string (sys:frame-to-string frame) + stream)) + +;;; Sorry, but can't seem to declare DEFIMPLEMENTATION under FLET. +;;; --ME 20150403 +(defun nth-frame-list (index) + (java:jcall "toLispList" (nth-frame index))) + +(defun match-lambda (operator values) + (jvm::match-lambda-list + (multiple-value-list + (jvm::parse-lambda-list (ext:arglist operator))) + values)) + +(defimplementation frame-locals (index) + (loop + :for id :upfrom 0 + :with frame = (nth-frame-list index) + :with operator = (first frame) + :with values = (rest frame) + :with arglist = (if (and operator (consp values) (not (null values))) + (handler-case + (match-lambda operator values) + (jvm::lambda-list-mismatch (e) + :lambda-list-mismatch)) + :not-available) + :for value :in values + :collecting (list + :name (if (not (keywordp arglist)) + (first (nth id arglist)) + (format nil "arg~A" id)) + :id id + :value value))) + +(defimplementation frame-var-value (index id) + (elt (rest (java:jcall "toLispList" (nth-frame index))) id)) + + +#+nil +(defimplementation disassemble-frame (index) + (disassemble (debugger:frame-function (nth-frame index)))) + +(defimplementation frame-source-location (index) + (let ((frame (nth-frame index))) + (or (source-location (nth-frame index)) + `(:error ,(format nil "No source for frame: ~a" frame))))) + +#+nil +(defimplementation eval-in-frame (form frame-number) + (debugger:eval-form-in-context + form + (debugger:environment-of-frame (nth-frame frame-number)))) + +#+nil +(defimplementation return-from-frame (frame-number form) + (let ((frame (nth-frame frame-number))) + (multiple-value-call #'debugger:frame-return + frame (debugger:eval-form-in-context + form + (debugger:environment-of-frame frame))))) + +;;; XXX doesn't work for frames with arguments +#+nil +(defimplementation restart-frame (frame-number) + (let ((frame (nth-frame frame-number))) + (debugger:frame-retry frame (debugger:frame-function frame)))) + +;;;; Compiler hooks + +(defvar *buffer-name* nil) +(defvar *buffer-start-position*) +(defvar *buffer-string*) +(defvar *compile-filename*) + +(defvar *abcl-signaled-conditions*) + +(defun handle-compiler-warning (condition) + (let ((loc (when (and jvm::*compile-file-pathname* + system::*source-position*) + (cons jvm::*compile-file-pathname* system::*source-position*)))) + ;; filter condition signaled more than once. + (unless (member condition *abcl-signaled-conditions*) + (push condition *abcl-signaled-conditions*) + (signal 'compiler-condition + :original-condition condition + :severity :warning + :message (format nil "~A" condition) + :location (cond (*buffer-name* + (make-location + (list :buffer *buffer-name*) + (list :offset *buffer-start-position* 0))) + (loc + (destructuring-bind (file . pos) loc + (make-location + (list :file (namestring (truename file))) + (list :position (1+ pos))))) + (t + (make-location + (list :file (namestring *compile-filename*)) + (list :position 1)))))))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore external-format policy)) + (let ((jvm::*resignal-compiler-warnings* t) + (*abcl-signaled-conditions* nil)) + (handler-bind ((warning #'handle-compiler-warning)) + (let ((*buffer-name* nil) + (*compile-filename* input-file)) + (multiple-value-bind (fn warn fail) + (compile-file input-file :output-file output-file) + (values fn warn + (and fn load-p + (not (load fn))))))))) + +(defimplementation swank-compile-string (string &key buffer position filename + policy) + (declare (ignore filename policy)) + (let ((jvm::*resignal-compiler-warnings* t) + (*abcl-signaled-conditions* nil)) + (handler-bind ((warning #'handle-compiler-warning)) + (let ((*buffer-name* buffer) + (*buffer-start-position* position) + (*buffer-string* string) + (sys::*source* (make-pathname :device "emacs-buffer" :name buffer)) + (sys::*source-position* position)) + (funcall (compile nil (read-from-string + (format nil "(~S () ~A)" 'lambda string)))) + t)))) + +#| +;;;; Definition Finding + +(defun find-fspec-location (fspec type) + (let ((file (excl::fspec-pathname fspec type))) + (etypecase file + (pathname + (let ((start (scm:find-definition-in-file fspec type file))) + (make-location (list :file (namestring (truename file))) + (if start + (list :position (1+ start)) + (list :function-name (string fspec)))))) + ((member :top-level) + (list :error (format nil "Defined at toplevel: ~A" fspec))) + (null + (list :error (format nil "Unkown source location for ~A" fspec)))))) + +(defun fspec-definition-locations (fspec) + (let ((defs (excl::find-multiple-definitions fspec))) + (loop for (fspec type) in defs + collect (list fspec (find-fspec-location fspec type))))) + +(defimplementation find-definitions (symbol) + (fspec-definition-locations symbol)) +|# + +(defgeneric source-location (object)) + +(defmethod source-location ((symbol symbol)) + (when (pathnamep (ext:source-pathname symbol)) + (let ((pos (ext:source-file-position symbol)) + (path (namestring (ext:source-pathname symbol)))) + (cond ((ext:pathname-jar-p path) + `(:location + ;; strip off "jar:file:" = 9 characters + (:zip ,@(split-string (subseq path 9) "!/")) + ;; pos never seems right. Use function name. + (:function-name ,(string symbol)) + (:align t))) + ((equal (pathname-device (ext:source-pathname symbol)) "emacs-buffer") + ;; conspire with swank-compile-string to keep the buffer + ;; name in a pathname whose device is "emacs-buffer". + `(:location + (:buffer ,(pathname-name (ext:source-pathname symbol))) + (:function-name ,(string symbol)) + (:align t))) + (t + `(:location + (:file ,path) + ,(if pos + (list :position (1+ pos)) + (list :function-name (string symbol))) + (:align t))))))) + +(defmethod source-location ((frame sys::java-stack-frame)) + (destructuring-bind (&key class method file line) (sys:frame-to-list frame) + (declare (ignore method)) + (let ((file (or (find-file-in-path file *source-path*) + (let ((f (format nil "~{~a/~}~a" + (butlast (split-string class "\\.")) + file))) + (find-file-in-path f *source-path*))))) + (and file + `(:location ,file (:line ,line) ()))))) + +(defmethod source-location ((frame sys::lisp-stack-frame)) + (destructuring-bind (operator &rest args) (sys:frame-to-list frame) + (declare (ignore args)) + (etypecase operator + (function (source-location operator)) + (list nil) + (symbol (source-location operator))))) + +(defmethod source-location ((fun function)) + (let ((name (function-name fun))) + (and name (source-location name)))) + +(defun system-property (name) + (java:jstatic "getProperty" "java.lang.System" name)) + +(defun pathname-parent (pathname) + (make-pathname :directory (butlast (pathname-directory pathname)))) + +(defun pathname-absolute-p (pathname) + (eq (car (pathname-directory pathname)) ':absolute)) + +(defun split-string (string regexp) + (coerce + (java:jcall (java:jmethod "java.lang.String" "split" "java.lang.String") + string regexp) + 'list)) + +(defun path-separator () + (java:jfield "java.io.File" "pathSeparator")) + +(defun search-path-property (prop-name) + (let ((string (system-property prop-name))) + (and string + (remove nil + (mapcar #'truename + (split-string string (path-separator))))))) + +(defun jdk-source-path () + (let* ((jre-home (truename (system-property "java.home"))) + (src-zip (merge-pathnames "src.zip" (pathname-parent jre-home))) + (truename (probe-file src-zip))) + (and truename (list truename)))) + +(defun class-path () + (append (search-path-property "java.class.path") + (search-path-property "sun.boot.class.path"))) + +(defvar *source-path* + (append (search-path-property "user.dir") + (jdk-source-path) + ;;(list (truename "/scratch/abcl/src")) + ) + "List of directories to search for source files.") + +(defun zipfile-contains-p (zipfile-name entry-name) + (let ((zipfile (java:jnew (java:jconstructor "java.util.zip.ZipFile" + "java.lang.String") + zipfile-name))) + (java:jcall + (java:jmethod "java.util.zip.ZipFile" "getEntry" "java.lang.String") + zipfile entry-name))) + +;; (find-file-in-path "java/lang/String.java" *source-path*) +;; (find-file-in-path "Lisp.java" *source-path*) + +;; Try to find FILENAME in PATH. If found, return a file spec as +;; needed by Emacs. We also look in zip files. +(defun find-file-in-path (filename path) + (labels ((try (dir) + (cond ((not (pathname-type dir)) + (let ((f (probe-file (merge-pathnames filename dir)))) + (and f `(:file ,(namestring f))))) + ((equal (pathname-type dir) "zip") + (try-zip dir)) + (t (error "strange path element: ~s" path)))) + (try-zip (zip) + (let* ((zipfile-name (namestring (truename zip)))) + (and (zipfile-contains-p zipfile-name filename) + `(:dir ,zipfile-name ,filename))))) + (cond ((pathname-absolute-p filename) (probe-file filename)) + (t + (loop for dir in path + if (try dir) return it))))) + +(defimplementation find-definitions (symbol) + (ext:resolve symbol) + (let ((srcloc (source-location symbol))) + (and srcloc `((,symbol ,srcloc))))) + +#| +Uncomment this if you have patched xref.lisp, as in +http://article.gmane.org/gmane.lisp.slime.devel/2425 +Also, make sure that xref.lisp is loaded by modifying the armedbear +part of *sysdep-pathnames* in swank.loader.lisp. + +;;;; XREF +(setq pxref:*handle-package-forms* '(cl:in-package)) + +(defmacro defxref (name function) + `(defimplementation ,name (name) + (xref-results (,function name)))) + +(defxref who-calls pxref:list-callers) +(defxref who-references pxref:list-readers) +(defxref who-binds pxref:list-setters) +(defxref who-sets pxref:list-setters) +(defxref list-callers pxref:list-callers) +(defxref list-callees pxref:list-callees) + +(defun xref-results (symbols) + (let ((xrefs '())) + (dolist (symbol symbols) + (push (list symbol (cadar (source-location symbol))) xrefs)) + xrefs)) +|# + +;;;; Inspecting +(defmethod emacs-inspect ((o t)) + (let ((parts (sys:inspected-parts o))) + `("The object is of type " ,(symbol-name (type-of o)) "." (:newline) + ,@(if parts + (loop :for (label . value) :in parts + :appending (label-value-line label value)) + (list "No inspectable parts, dumping output of CL:DESCRIBE:" + '(:newline) + (with-output-to-string (desc) (describe o desc))))))) + +(defmethod emacs-inspect ((slot mop::slot-definition)) + `("Name: " + (:value ,(mop:slot-definition-name slot)) + (:newline) + "Documentation:" (:newline) + ,@(when (slot-definition-documentation slot) + `((:value ,(slot-definition-documentation slot)) (:newline))) + "Initialization:" (:newline) + " Args: " (:value ,(mop:slot-definition-initargs slot)) (:newline) + " Form: " ,(if (mop:slot-definition-initfunction slot) + `(:value ,(mop:slot-definition-initform slot)) + "#<unspecified>") (:newline) + " Function: " + (:value ,(mop:slot-definition-initfunction slot)) + (:newline))) + +(defmethod emacs-inspect ((f function)) + `(,@(when (function-name f) + `("Name: " + ,(princ-to-string (function-name f)) (:newline))) + ,@(multiple-value-bind (args present) + (sys::arglist f) + (when present + `("Argument list: " + ,(princ-to-string args) (:newline)))) + (:newline) + #+nil,@(when (documentation f t) + `("Documentation:" (:newline) + ,(documentation f t) (:newline))) + ,@(when (function-lambda-expression f) + `("Lambda expression:" + (:newline) ,(princ-to-string + (function-lambda-expression f)) (:newline))))) + +;;; Although by convention toString() is supposed to be a +;;; non-computationally expensive operation this isn't always the +;;; case, so make its computation a user interaction. +(defparameter *to-string-hashtable* (make-hash-table)) +(defmethod emacs-inspect ((o java:java-object)) + (let ((to-string (lambda () + (handler-case + (setf (gethash o *to-string-hashtable*) + (java:jcall "toString" o)) + (t (e) + (setf (gethash o *to-string-hashtable*) + (format nil + "Could not invoke toString(): ~A" + e))))))) + (append + (if (gethash o *to-string-hashtable*) + (label-value-line "toString()" (gethash o *to-string-hashtable*)) + `((:action "[compute toString()]" ,to-string) (:newline))) + (loop :for (label . value) :in (sys:inspected-parts o) + :appending (label-value-line label value))))) + +;;;; Multithreading + +(defimplementation spawn (fn &key name) + (threads:make-thread (lambda () (funcall fn)) :name name)) + +(defvar *thread-plists* (make-hash-table) ; should be a weak table + "A hashtable mapping threads to a plist.") + +(defvar *thread-id-counter* 0) + +(defimplementation thread-id (thread) + (threads:synchronized-on *thread-plists* + (or (getf (gethash thread *thread-plists*) 'id) + (setf (getf (gethash thread *thread-plists*) 'id) + (incf *thread-id-counter*))))) + +(defimplementation find-thread (id) + (find id (all-threads) + :key (lambda (thread) + (getf (gethash thread *thread-plists*) 'id)))) + +(defimplementation thread-name (thread) + (threads:thread-name thread)) + +(defimplementation thread-status (thread) + (format nil "Thread is ~:[dead~;alive~]" (threads:thread-alive-p thread))) + +(defimplementation make-lock (&key name) + (declare (ignore name)) + (threads:make-thread-lock)) + +(defimplementation call-with-lock-held (lock function) + (threads:with-thread-lock (lock) (funcall function))) + +(defimplementation current-thread () + (threads:current-thread)) + +(defimplementation all-threads () + (copy-list (threads:mapcar-threads #'identity))) + +(defimplementation thread-alive-p (thread) + (member thread (all-threads))) + +(defimplementation interrupt-thread (thread fn) + (threads:interrupt-thread thread fn)) + +(defimplementation kill-thread (thread) + (threads:destroy-thread thread)) + +(defstruct mailbox + (queue '())) + +(defun mailbox (thread) + "Return THREAD's mailbox." + (threads:synchronized-on *thread-plists* + (or (getf (gethash thread *thread-plists*) 'mailbox) + (setf (getf (gethash thread *thread-plists*) 'mailbox) + (make-mailbox))))) + +(defimplementation send (thread message) + (let ((mbox (mailbox thread))) + (threads:synchronized-on mbox + (setf (mailbox-queue mbox) + (nconc (mailbox-queue mbox) (list message))) + (threads:object-notify-all mbox)))) + +(defimplementation receive-if (test &optional timeout) + (let* ((mbox (mailbox (current-thread)))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (threads:synchronized-on mbox + (let* ((q (mailbox-queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox-queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail))) + (when (eq timeout t) (return (values nil t))) + (threads:object-wait mbox 0.3)))))) + +(defimplementation quit-lisp () + (ext:exit)) +;;; +#+#.(swank/backend:with-symbol 'package-local-nicknames 'ext) +(defimplementation package-local-nicknames (package) + (ext:package-local-nicknames package)) diff --git a/vim/bundle/slimv/slime/swank/allegro.lisp b/vim/bundle/slimv/slime/swank/allegro.lisp new file mode 100644 index 0000000..f5918da --- /dev/null +++ b/vim/bundle/slimv/slime/swank/allegro.lisp @@ -0,0 +1,1053 @@ +;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;* "; -*- +;;; +;;; swank-allegro.lisp --- Allegro CL specific code for SLIME. +;;; +;;; Created 2003 +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(defpackage swank/allegro + (:use cl swank/backend)) + +(in-package swank/allegro) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :sock) + (require :process) + #+(version>= 8 2) + (require 'lldb)) + +(defimplementation gray-package-name () + '#:excl) + +;;; swank-mop + +(import-swank-mop-symbols :clos '(:slot-definition-documentation)) + +(defun swank-mop:slot-definition-documentation (slot) + (documentation slot t)) + + +;;;; UTF8 + +(define-symbol-macro utf8-ef + (load-time-value + (excl:crlf-base-ef (excl:find-external-format :utf-8)) + t)) + +(defimplementation string-to-utf8 (s) + (excl:string-to-octets s :external-format utf8-ef + :null-terminate nil)) + +(defimplementation utf8-to-string (u) + (excl:octets-to-string u :external-format utf8-ef)) + + +;;;; TCP Server + +(defimplementation preferred-communication-style () + :spawn) + +(defimplementation create-socket (host port &key backlog) + (socket:make-socket :connect :passive :local-port port + :local-host host :reuse-address t + :backlog (or backlog 5))) + +(defimplementation local-port (socket) + (socket:local-port socket)) + +(defimplementation close-socket (socket) + (close socket)) + +(defimplementation accept-connection (socket &key external-format buffering + timeout) + (declare (ignore buffering timeout)) + (let ((s (socket:accept-connection socket :wait t))) + (when external-format + (setf (stream-external-format s) external-format)) + s)) + +(defimplementation socket-fd (stream) + (excl::stream-input-handle stream)) + +(defvar *external-format-to-coding-system* + '((:iso-8859-1 + "latin-1" "latin-1-unix" "iso-latin-1-unix" + "iso-8859-1" "iso-8859-1-unix") + (:utf-8 "utf-8" "utf-8-unix") + (:euc-jp "euc-jp" "euc-jp-unix") + (:us-ascii "us-ascii" "us-ascii-unix") + (:emacs-mule "emacs-mule" "emacs-mule-unix"))) + +(defimplementation find-external-format (coding-system) + (let ((e (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + (and e (excl:crlf-base-ef + (excl:find-external-format (car e) + :try-variant t))))) + +;;;; Unix signals + +(defimplementation getpid () + (excl::getpid)) + +(defimplementation lisp-implementation-type-name () + "allegro") + +(defimplementation set-default-directory (directory) + (let* ((dir (namestring (truename (merge-pathnames directory))))) + (setf *default-pathname-defaults* (pathname (excl:chdir dir))) + dir)) + +(defimplementation default-directory () + (namestring (excl:current-directory))) + +;;;; Misc + +(defimplementation arglist (symbol) + (handler-case (excl:arglist symbol) + (simple-error () :not-available))) + +(defimplementation macroexpand-all (form &optional env) + (declare (ignore env)) + #+(version>= 8 0) + (excl::walk-form form) + #-(version>= 8 0) + (excl::walk form)) + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind &optional (sym symbol)) + (or (documentation sym kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (when (boundp symbol) + (doc 'variable))) + (maybe-push + :function (if (fboundp symbol) + (doc 'function))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + result))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + (:variable + (describe symbol)) + ((:function :generic-function) + (describe (symbol-function symbol))) + (:class + (describe (find-class symbol))))) + +(defimplementation type-specifier-p (symbol) + (or (ignore-errors + (subtypep nil symbol)) + (not (eq (type-specifier-arglist symbol) :not-available)))) + +(defimplementation function-name (f) + (check-type f function) + (cross-reference::object-to-function-name f)) + +;;;; Debugger + +(defvar *sldb-topframe*) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (let ((*sldb-topframe* (find-topframe)) + (excl::*break-hook* nil)) + (funcall debugger-loop-fn))) + +(defimplementation sldb-break-at-start (fname) + ;; :print-before is kind of mis-used but we just want to stuff our + ;; break form somewhere. This does not work for setf, :before and + ;; :after methods, which need special syntax in the trace call, see + ;; ACL's doc/debugging.htm chapter 10. + (eval `(trace (,fname + :print-before + ((break "Function start breakpoint of ~A" ',fname))))) + `(:ok ,(format nil "Set breakpoint at start of ~S" fname))) + +(defun find-topframe () + (let ((magic-symbol (intern (symbol-name :swank-debugger-hook) + (find-package :swank))) + (top-frame (excl::int-newest-frame (excl::current-thread)))) + (loop for frame = top-frame then (next-frame frame) + for i from 0 + while (and frame (< i 30)) + when (eq (debugger:frame-name frame) magic-symbol) + return (next-frame frame) + finally (return top-frame)))) + +(defun next-frame (frame) + (let ((next (excl::int-next-older-frame frame))) + (cond ((not next) nil) + ((debugger:frame-visible-p next) next) + (t (next-frame next))))) + +(defun nth-frame (index) + (do ((frame *sldb-topframe* (next-frame frame)) + (i index (1- i))) + ((zerop i) frame))) + +(defimplementation compute-backtrace (start end) + (let ((end (or end most-positive-fixnum))) + (loop for f = (nth-frame start) then (next-frame f) + for i from start below end + while f collect f))) + +(defimplementation print-frame (frame stream) + (debugger:output-frame stream frame :moderate)) + +(defimplementation frame-locals (index) + (let ((frame (nth-frame index))) + (loop for i from 0 below (debugger:frame-number-vars frame) + collect (list :name (debugger:frame-var-name frame i) + :id 0 + :value (debugger:frame-var-value frame i))))) + +(defimplementation frame-var-value (frame var) + (let ((frame (nth-frame frame))) + (debugger:frame-var-value frame var))) + +(defimplementation disassemble-frame (index) + (let ((frame (nth-frame index))) + (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame) + (format t "pc: ~d (~s ~s ~s)~%fun: ~a~%" pc x xx xxx fun) + (disassemble (debugger:frame-function frame))))) + +(defimplementation frame-source-location (index) + (let* ((frame (nth-frame index))) + (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame) + (declare (ignore x xx xxx)) + (cond ((and pc + #+(version>= 8 2) + (pc-source-location fun pc) + #-(version>= 8 2) + (function-source-location fun))) + (t ; frames for unbound functions etc end up here + (cadr (car (fspec-definition-locations + (car (debugger:frame-expression frame)))))))))) + +(defun function-source-location (fun) + (cadr (car (fspec-definition-locations + (xref::object-to-function-name fun))))) + +#+(version>= 8 2) +(defun pc-source-location (fun pc) + (let* ((debug-info (excl::function-source-debug-info fun))) + (cond ((not debug-info) + (function-source-location fun)) + (t + (let* ((code-loc (find-if (lambda (c) + (<= (- pc (sys::natural-width)) + (let ((x (excl::ldb-code-pc c))) + (or x -1)) + pc)) + debug-info))) + (cond ((not code-loc) + (ldb-code-to-src-loc (aref debug-info 0))) + (t + (ldb-code-to-src-loc code-loc)))))))) + +#+(version>= 8 2) +(defun ldb-code-to-src-loc (code) + (declare (optimize debug)) + (let* ((func (excl::ldb-code-func code)) + (debug-info (excl::function-source-debug-info func)) + (start (loop for i from (excl::ldb-code-index code) downto 0 + for bpt = (aref debug-info i) + for start = (excl::ldb-code-start-char bpt) + when start return start)) + (src-file (excl:source-file func))) + (cond (start + (buffer-or-file-location src-file start)) + (func + (let* ((debug-info (excl::function-source-debug-info func)) + (whole (aref debug-info 0)) + (paths (source-paths-of (excl::ldb-code-source whole) + (excl::ldb-code-source code))) + (path (if paths (longest-common-prefix paths) '())) + (start 0)) + (buffer-or-file + src-file + (lambda (file) + (make-location `(:file ,file) + `(:source-path (0 . ,path) ,start))) + (lambda (buffer bstart) + (make-location `(:buffer ,buffer) + `(:source-path (0 . ,path) + ,(+ bstart start))))))) + (t + nil)))) + +(defun longest-common-prefix (sequences) + (assert sequences) + (flet ((common-prefix (s1 s2) + (let ((diff-pos (mismatch s1 s2))) + (if diff-pos (subseq s1 0 diff-pos) s1)))) + (reduce #'common-prefix sequences))) + +(defun source-paths-of (whole part) + (let ((result '())) + (labels ((walk (form path) + (cond ((eq form part) + (push (reverse path) result)) + ((consp form) + (loop for i from 0 while (consp form) do + (walk (pop form) (cons i path))))))) + (walk whole '()) + (reverse result)))) + +(defimplementation eval-in-frame (form frame-number) + (let ((frame (nth-frame frame-number))) + ;; let-bind lexical variables + (let ((vars (loop for i below (debugger:frame-number-vars frame) + for name = (debugger:frame-var-name frame i) + if (typep name '(and symbol (not null) (not keyword))) + collect `(,name ',(debugger:frame-var-value frame i))))) + (debugger:eval-form-in-context + `(let* ,vars ,form) + (debugger:environment-of-frame frame))))) + +(defimplementation frame-package (frame-number) + (let* ((frame (nth-frame frame-number)) + (exp (debugger:frame-expression frame))) + (typecase exp + ((cons symbol) (symbol-package (car exp))) + ((cons (cons (eql :internal) (cons symbol))) + (symbol-package (cadar exp)))))) + +(defimplementation return-from-frame (frame-number form) + (let ((frame (nth-frame frame-number))) + (multiple-value-call #'debugger:frame-return + frame (debugger:eval-form-in-context + form + (debugger:environment-of-frame frame))))) + +(defimplementation frame-restartable-p (frame) + (handler-case (debugger:frame-retryable-p frame) + (serious-condition (c) + (funcall (read-from-string "swank::background-message") + "~a ~a" frame (princ-to-string c)) + nil))) + +(defimplementation restart-frame (frame-number) + (let ((frame (nth-frame frame-number))) + (cond ((debugger:frame-retryable-p frame) + (apply #'debugger:frame-retry frame (debugger:frame-function frame) + (cdr (debugger:frame-expression frame)))) + (t "Frame is not retryable")))) + +;;;; Compiler hooks + +(defvar *buffer-name* nil) +(defvar *buffer-start-position*) +(defvar *buffer-string*) +(defvar *compile-filename* nil) + +(defun compiler-note-p (object) + (member (type-of object) '(excl::compiler-note compiler::compiler-note))) + +(defun redefinition-p (condition) + (and (typep condition 'style-warning) + (every #'char-equal "redefin" (princ-to-string condition)))) + +(defun compiler-undefined-functions-called-warning-p (object) + (typep object 'excl:compiler-undefined-functions-called-warning)) + +(deftype compiler-note () + `(satisfies compiler-note-p)) + +(deftype redefinition () + `(satisfies redefinition-p)) + +(defun signal-compiler-condition (&rest args) + (apply #'signal 'compiler-condition args)) + +(defun handle-compiler-warning (condition) + (declare (optimize (debug 3) (speed 0) (space 0))) + (cond ((and #-(version>= 10 0) (not *buffer-name*) + (compiler-undefined-functions-called-warning-p condition)) + (handle-undefined-functions-warning condition)) + ((and (typep condition 'excl::compiler-note) + (let ((format (slot-value condition 'excl::format-control))) + (and (search "Closure" format) + (search "will be stack allocated" format)))) + ;; Ignore "Closure <foo> will be stack allocated" notes. + ;; That occurs often but is usually uninteresting. + ) + (t + (signal-compiler-condition + :original-condition condition + :severity (etypecase condition + (redefinition :redefinition) + (style-warning :style-warning) + (warning :warning) + (compiler-note :note) + (reader-error :read-error) + (error :error)) + :message (format nil "~A" condition) + :location (compiler-warning-location condition))))) + +(defun condition-pathname-and-position (condition) + (let* ((context #+(version>= 10 0) + (getf (slot-value condition 'excl::plist) + :source-context)) + (location-available (and context + (excl::source-context-start-char context)))) + (cond (location-available + (values (excl::source-context-pathname context) + (when-let (start-char (excl::source-context-start-char context)) + (1+ (if (listp start-char) ; HACK + (first start-char) + start-char))))) + ((typep condition 'reader-error) + (let ((pos (car (last (slot-value condition 'excl::format-arguments)))) + (file (pathname (stream-error-stream condition)))) + (when (integerp pos) + (values file pos)))) + (t + (let ((loc (getf (slot-value condition 'excl::plist) :loc))) + (when loc + (destructuring-bind (file . pos) loc + (let ((start (if (consp pos) ; 8.2 and newer + (car pos) + pos))) + (values file (1+ start)))))))))) + +(defun compiler-warning-location (condition) + (multiple-value-bind (pathname position) + (condition-pathname-and-position condition) + (cond (*buffer-name* + (make-location + (list :buffer *buffer-name*) + (if position + (list :position position) + (list :offset *buffer-start-position* 0)))) + (pathname + (make-location + (list :file (namestring (truename pathname))) + (list :position position))) + (t + (make-error-location "No error location available."))))) + +;; TODO: report it as a bug to Franz that the condition's plist +;; slot contains (:loc nil). +(defun handle-undefined-functions-warning (condition) + (let ((fargs (slot-value condition 'excl::format-arguments))) + (loop for (fname . locs) in (car fargs) do + (dolist (loc locs) + (multiple-value-bind (pos file) (ecase (length loc) + (2 (values-list loc)) + (3 (destructuring-bind + (start end file) loc + (declare (ignore end)) + (values start file)))) + (signal-compiler-condition + :original-condition condition + :severity :warning + :message (format nil "Undefined function referenced: ~S" + fname) + :location (make-location (list :file file) + (list :position (1+ pos))))))))) + +(defimplementation call-with-compilation-hooks (function) + (handler-bind ((warning #'handle-compiler-warning) + (compiler-note #'handle-compiler-warning) + (reader-error #'handle-compiler-warning)) + (funcall function))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (handler-case + (with-compilation-hooks () + (let ((*buffer-name* nil) + (*compile-filename* input-file) + #+(version>= 8 2) + (compiler:save-source-level-debug-info-switch t) + (excl:*load-source-file-info* t) + #+(version>= 8 2) + (excl:*load-source-debug-info* t)) + (compile-file *compile-filename* + :output-file output-file + :load-after-compile load-p + :external-format external-format))) + (reader-error () (values nil nil t)))) + +(defun call-with-temp-file (fn) + (let ((tmpname (system:make-temp-file-name))) + (unwind-protect + (with-open-file (file tmpname :direction :output :if-exists :error) + (funcall fn file tmpname)) + (delete-file tmpname)))) + +(defvar *temp-file-map* (make-hash-table :test #'equal) + "A mapping from tempfile names to Emacs buffer names.") + +(defun write-tracking-preamble (stream file file-offset) + "Instrument the top of the temporary file to be compiled. + +The header tells allegro that any definitions compiled in the temp +file should be found in FILE exactly at FILE-OFFSET. To get Allegro +to do this, this factors in the length of the inserted header itself." + (with-standard-io-syntax + (let* ((*package* (find-package :keyword)) + (source-pathname-form + `(cl:eval-when (:compile-toplevel :load-toplevel :execute) + (cl:setq excl::*source-pathname* + (pathname ,(sys::frob-source-file file))))) + (source-pathname-string (write-to-string source-pathname-form)) + (position-form-length-bound 160) ; should be enough for everyone + (header-length (+ (length source-pathname-string) + position-form-length-bound)) + (position-form + `(cl:eval-when (:compile-toplevel :load-toplevel :execute) + (cl:setq excl::*partial-source-file-p* ,(- file-offset + header-length + 1 ; for the newline + )))) + (position-form-string (write-to-string position-form)) + (padding-string (make-string (- position-form-length-bound + (length position-form-string)) + :initial-element #\;))) + (write-string source-pathname-string stream) + (write-string position-form-string stream) + (write-string padding-string stream) + (write-char #\newline stream)))) + +(defun compile-from-temp-file (string buffer offset file) + (call-with-temp-file + (lambda (stream filename) + (when (and file offset (probe-file file)) + (write-tracking-preamble stream file offset)) + (write-string string stream) + (finish-output stream) + (multiple-value-bind (binary-filename warnings? failure?) + (let ((sys:*source-file-types* '(nil)) ; suppress .lisp extension + #+(version>= 8 2) + (compiler:save-source-level-debug-info-switch t) + (excl:*redefinition-warnings* nil)) + (compile-file filename)) + (declare (ignore warnings?)) + (when binary-filename + (let ((excl:*load-source-file-info* t) + #+(version>= 8 2) + (excl:*load-source-debug-info* t)) + excl::*source-pathname* + (load binary-filename)) + (when (and buffer offset (or (not file) + (not (probe-file file)))) + (setf (gethash (pathname stream) *temp-file-map*) + (list buffer offset))) + (delete-file binary-filename)) + (not failure?))))) + +(defimplementation swank-compile-string (string &key buffer position filename + policy) + (declare (ignore policy)) + (handler-case + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-start-position* position) + (*buffer-string* string)) + (compile-from-temp-file string buffer position filename))) + (reader-error () nil))) + +;;;; Definition Finding + +(defun buffer-or-file (file file-fun buffer-fun) + (let* ((probe (gethash file *temp-file-map*))) + (cond (probe + (destructuring-bind (buffer start) probe + (funcall buffer-fun buffer start))) + (t (funcall file-fun (namestring (truename file))))))) + +(defun buffer-or-file-location (file offset) + (buffer-or-file file + (lambda (filename) + (make-location `(:file ,filename) + `(:position ,(1+ offset)))) + (lambda (buffer start) + (make-location `(:buffer ,buffer) + `(:offset ,start ,offset))))) + +(defun fspec-primary-name (fspec) + (etypecase fspec + (symbol fspec) + (list (fspec-primary-name (second fspec))))) + +(defun find-definition-in-file (fspec type file top-level) + (let* ((part + (or (scm::find-definition-in-definition-group + fspec type (scm:section-file :file file) + :top-level top-level) + (scm::find-definition-in-definition-group + (fspec-primary-name fspec) + type (scm:section-file :file file) + :top-level top-level))) + (start (and part + (scm::source-part-start part))) + (pos (if start + (list :position (1+ start)) + (list :function-name (string (fspec-primary-name fspec)))))) + (make-location (list :file (namestring (truename file))) + pos))) + +(defun find-fspec-location (fspec type file top-level) + (handler-case + (etypecase file + (pathname + (let ((probe (gethash file *temp-file-map*))) + (cond (probe + (destructuring-bind (buffer offset) probe + (make-location `(:buffer ,buffer) + `(:offset ,offset 0)))) + (t + (find-definition-in-file fspec type file top-level))))) + ((member :top-level) + (make-error-location "Defined at toplevel: ~A" + (fspec->string fspec)))) + (error (e) + (make-error-location "Error: ~A" e)))) + +(defun fspec->string (fspec) + (typecase fspec + (symbol (let ((*package* (find-package :keyword))) + (prin1-to-string fspec))) + (list (format nil "(~A ~A)" + (prin1-to-string (first fspec)) + (let ((*package* (find-package :keyword))) + (prin1-to-string (second fspec))))) + (t (princ-to-string fspec)))) + +(defun fspec-definition-locations (fspec) + (cond + ((and (listp fspec) (eq (car fspec) :internal)) + (destructuring-bind (_internal next _n) fspec + (declare (ignore _internal _n)) + (fspec-definition-locations next))) + (t + (let ((defs (excl::find-source-file fspec))) + (when (and (null defs) + (listp fspec) + (string= (car fspec) '#:method)) + ;; If methods are defined in a defgeneric form, the source location is + ;; recorded for the gf but not for the methods. Therefore fall back to + ;; the gf as the likely place of definition. + (setq defs (excl::find-source-file (second fspec)))) + (if (null defs) + (list + (list fspec + (make-error-location "Unknown source location for ~A" + (fspec->string fspec)))) + (loop for (fspec type file top-level) in defs collect + (list (list type fspec) + (find-fspec-location fspec type file top-level)))))))) + +(defimplementation find-definitions (symbol) + (fspec-definition-locations symbol)) + +(defimplementation find-source-location (obj) + (first (rest (first (fspec-definition-locations obj))))) + +;;;; XREF + +(defmacro defxref (name relation name1 name2) + `(defimplementation ,name (x) + (xref-result (xref:get-relation ,relation ,name1 ,name2)))) + +(defxref who-calls :calls :wild x) +(defxref calls-who :calls x :wild) +(defxref who-references :uses :wild x) +(defxref who-binds :binds :wild x) +(defxref who-macroexpands :macro-calls :wild x) +(defxref who-sets :sets :wild x) + +(defun xref-result (fspecs) + (loop for fspec in fspecs + append (fspec-definition-locations fspec))) + +;; list-callers implemented by groveling through all fbound symbols. +;; Only symbols are considered. Functions in the constant pool are +;; searched recursively. Closure environments are ignored at the +;; moment (constants in methods are therefore not found). + +(defun map-function-constants (function fn depth) + "Call FN with the elements of FUNCTION's constant pool." + (do ((i 0 (1+ i)) + (max (excl::function-constant-count function))) + ((= i max)) + (let ((c (excl::function-constant function i))) + (cond ((and (functionp c) + (not (eq c function)) + (plusp depth)) + (map-function-constants c fn (1- depth))) + (t + (funcall fn c)))))) + +(defun in-constants-p (fun symbol) + (map-function-constants fun + (lambda (c) + (when (eq c symbol) + (return-from in-constants-p t))) + 3)) + +(defun function-callers (name) + (let ((callers '())) + (do-all-symbols (sym) + (when (fboundp sym) + (let ((fn (fdefinition sym))) + (when (in-constants-p fn name) + (push sym callers))))) + callers)) + +(defimplementation list-callers (name) + (xref-result (function-callers name))) + +(defimplementation list-callees (name) + (let ((result '())) + (map-function-constants (fdefinition name) + (lambda (c) + (when (fboundp c) + (push c result))) + 2) + (xref-result result))) + +;;;; Profiling + +;; Per-function profiling based on description in +;; http://www.franz.com/support/documentation/8.0/\ +;; doc/runtime-analyzer.htm#data-collection-control-2 + +(defvar *profiled-functions* ()) +(defvar *profile-depth* 0) + +(defmacro with-redirected-y-or-n-p (&body body) + ;; If the profiler is restarted when the data from the previous + ;; session is not reported yet, the user is warned via Y-OR-N-P. + ;; As the CL:Y-OR-N-P question is (for some reason) not directly + ;; sent to the Slime user, the function CL:Y-OR-N-P is temporarily + ;; overruled. + `(let* ((pkg (find-package :common-lisp)) + (saved-pdl (excl::package-definition-lock pkg)) + (saved-ynp (symbol-function 'cl:y-or-n-p))) + (setf (excl::package-definition-lock pkg) nil + (symbol-function 'cl:y-or-n-p) + (symbol-function (read-from-string "swank:y-or-n-p-in-emacs"))) + (unwind-protect + (progn ,@body) + (setf (symbol-function 'cl:y-or-n-p) saved-ynp + (excl::package-definition-lock pkg) saved-pdl)))) + +(defun start-acl-profiler () + (with-redirected-y-or-n-p + (prof:start-profiler :type :time :count t + :start-sampling-p nil :verbose nil))) +(defun acl-profiler-active-p () + (not (eq (prof:profiler-status :verbose nil) :inactive))) + +(defun stop-acl-profiler () + (prof:stop-profiler :verbose nil)) + +(excl:def-fwrapper profile-fwrapper (&rest args) + ;; Ensures sampling is done during the execution of the function, + ;; taking into account recursion. + (declare (ignore args)) + (cond ((zerop *profile-depth*) + (let ((*profile-depth* (1+ *profile-depth*))) + (prof:start-sampling) + (unwind-protect (excl:call-next-fwrapper) + (prof:stop-sampling)))) + (t + (excl:call-next-fwrapper)))) + +(defimplementation profile (fname) + (unless (acl-profiler-active-p) + (start-acl-profiler)) + (excl:fwrap fname 'profile-fwrapper 'profile-fwrapper) + (push fname *profiled-functions*)) + +(defimplementation profiled-functions () + *profiled-functions*) + +(defimplementation unprofile (fname) + (excl:funwrap fname 'profile-fwrapper) + (setq *profiled-functions* (remove fname *profiled-functions*))) + +(defimplementation profile-report () + (prof:show-flat-profile :verbose nil) + (when *profiled-functions* + (start-acl-profiler))) + +(defimplementation profile-reset () + (when (acl-profiler-active-p) + (stop-acl-profiler) + (start-acl-profiler)) + "Reset profiling counters.") + +;;;; Inspecting + +(excl:without-redefinition-warnings +(defmethod emacs-inspect ((o t)) + (allegro-inspect o))) + +(defmethod emacs-inspect ((o function)) + (allegro-inspect o)) + +(defmethod emacs-inspect ((o standard-object)) + (allegro-inspect o)) + +(defun allegro-inspect (o) + (loop for (d dd) on (inspect::inspect-ctl o) + append (frob-allegro-field-def o d) + until (eq d dd))) + +(defun frob-allegro-field-def (object def) + (with-struct (inspect::field-def- name type access) def + (ecase type + ((:unsigned-word :unsigned-byte :unsigned-natural + :unsigned-long :unsigned-half-long + :unsigned-3byte :unsigned-long32) + (label-value-line name (inspect::component-ref-v object access type))) + ((:lisp :value :func) + (label-value-line name (inspect::component-ref object access))) + (:indirect + (destructuring-bind (prefix count ref set) access + (declare (ignore set prefix)) + (loop for i below (funcall count object) + append (label-value-line (format nil "~A-~D" name i) + (funcall ref object i)))))))) + +;;;; Multithreading + +(defimplementation initialize-multiprocessing (continuation) + (mp:start-scheduler) + (funcall continuation)) + +(defimplementation spawn (fn &key name) + (mp:process-run-function name fn)) + +(defvar *id-lock* (mp:make-process-lock :name "id lock")) +(defvar *thread-id-counter* 0) + +(defimplementation thread-id (thread) + (mp:with-process-lock (*id-lock*) + (or (getf (mp:process-property-list thread) 'id) + (setf (getf (mp:process-property-list thread) 'id) + (incf *thread-id-counter*))))) + +(defimplementation find-thread (id) + (find id mp:*all-processes* + :key (lambda (p) (getf (mp:process-property-list p) 'id)))) + +(defimplementation thread-name (thread) + (mp:process-name thread)) + +(defimplementation thread-status (thread) + (princ-to-string (mp:process-whostate thread))) + +(defimplementation thread-attributes (thread) + (list :priority (mp:process-priority thread) + :times-resumed (mp:process-times-resumed thread))) + +(defimplementation make-lock (&key name) + (mp:make-process-lock :name name)) + +(defimplementation call-with-lock-held (lock function) + (mp:with-process-lock (lock) (funcall function))) + +(defimplementation current-thread () + mp:*current-process*) + +(defimplementation all-threads () + (copy-list mp:*all-processes*)) + +(defimplementation interrupt-thread (thread fn) + (mp:process-interrupt thread fn)) + +(defimplementation kill-thread (thread) + (mp:process-kill thread)) + +(defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock")) + +(defstruct (mailbox (:conc-name mailbox.)) + (lock (mp:make-process-lock :name "process mailbox")) + (queue '() :type list) + (gate (mp:make-gate nil))) + +(defun mailbox (thread) + "Return THREAD's mailbox." + (mp:with-process-lock (*mailbox-lock*) + (or (getf (mp:process-property-list thread) 'mailbox) + (setf (getf (mp:process-property-list thread) 'mailbox) + (make-mailbox))))) + +(defimplementation send (thread message) + (let* ((mbox (mailbox thread))) + (mp:with-process-lock ((mailbox.lock mbox)) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + (mp:open-gate (mailbox.gate mbox))))) + +(defimplementation receive-if (test &optional timeout) + (let ((mbox (mailbox mp:*current-process*))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (mp:with-process-lock ((mailbox.lock mbox)) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail))) + (mp:close-gate (mailbox.gate mbox)))) + (when (eq timeout t) (return (values nil t))) + (mp:process-wait-with-timeout "receive-if" 0.5 + #'mp:gate-open-p (mailbox.gate mbox))))) + +(let ((alist '()) + (lock (mp:make-process-lock :name "register-thread"))) + + (defimplementation register-thread (name thread) + (declare (type symbol name)) + (mp:with-process-lock (lock) + (etypecase thread + (null + (setf alist (delete name alist :key #'car))) + (mp:process + (let ((probe (assoc name alist))) + (cond (probe (setf (cdr probe) thread)) + (t (setf alist (acons name thread alist)))))))) + nil) + + (defimplementation find-registered (name) + (mp:with-process-lock (lock) + (cdr (assoc name alist))))) + +(defimplementation set-default-initial-binding (var form) + (push (cons var form) + #+(version>= 9 0) + excl:*required-thread-bindings* + #-(version>= 9 0) + excl::required-thread-bindings)) + +(defimplementation quit-lisp () + (excl:exit 0 :quiet t)) + + +;;Trace implementations +;;In Allegro 7.0, we have: +;; (trace <name>) +;; (trace ((method <name> <qualifier>? (<specializer>+)))) +;; (trace ((labels <name> <label-name>))) +;; (trace ((labels (method <name> (<specializer>+)) <label-name>))) +;; <name> can be a normal name or a (setf name) + +(defimplementation toggle-trace (spec) + (ecase (car spec) + ((setf) + (toggle-trace-aux spec)) + (:defgeneric (toggle-trace-generic-function-methods (second spec))) + ((setf :defmethod :labels :flet) + (toggle-trace-aux (process-fspec-for-allegro spec))) + (:call + (destructuring-bind (caller callee) (cdr spec) + (toggle-trace-aux callee + :inside (list (process-fspec-for-allegro caller))))))) + +(defun tracedp (fspec) + (member fspec (eval '(trace)) :test #'equal)) + +(defun toggle-trace-aux (fspec &rest args) + (cond ((tracedp fspec) + (eval `(untrace ,fspec)) + (format nil "~S is now untraced." fspec)) + (t + (eval `(trace (,fspec ,@args))) + (format nil "~S is now traced." fspec)))) + +(defun toggle-trace-generic-function-methods (name) + (let ((methods (mop:generic-function-methods (fdefinition name)))) + (cond ((tracedp name) + (eval `(untrace ,name)) + (dolist (method methods (format nil "~S is now untraced." name)) + (excl:funtrace (mop:method-function method)))) + (t + (eval `(trace (,name))) + (dolist (method methods (format nil "~S is now traced." name)) + (excl:ftrace (mop:method-function method))))))) + +(defun process-fspec-for-allegro (fspec) + (cond ((consp fspec) + (ecase (first fspec) + ((setf) fspec) + ((:defun :defgeneric) (second fspec)) + ((:defmethod) `(method ,@(rest fspec))) + ((:labels) `(labels ,(process-fspec-for-allegro (second fspec)) + ,(third fspec))) + ((:flet) `(flet ,(process-fspec-for-allegro (second fspec)) + ,(third fspec))))) + (t + fspec))) + + +;;;; Weak hashtables + +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak-keys t args)) + +(defimplementation make-weak-value-hash-table (&rest args) + (apply #'make-hash-table :values :weak args)) + +(defimplementation hash-table-weakness (hashtable) + (cond ((excl:hash-table-weak-keys hashtable) :key) + ((eq (excl:hash-table-values hashtable) :weak) :value))) + + + +;;;; Character names + +(defimplementation character-completion-set (prefix matchp) + (loop for name being the hash-keys of excl::*name-to-char-table* + when (funcall matchp prefix name) + collect (string-capitalize name))) + + +;;;; wrap interface implementation + +(defimplementation wrap (spec indicator &key before after replace) + (let ((allegro-spec (process-fspec-for-allegro spec))) + (excl:fwrap allegro-spec + indicator + (excl:def-fwrapper allegro-wrapper (&rest args) + (let (retlist completed) + (unwind-protect + (progn + (when before + (funcall before args)) + (setq retlist (multiple-value-list + (if replace + (funcall replace args) + (excl:call-next-fwrapper)))) + (setq completed t) + (values-list retlist)) + (when after + (funcall after (if completed + retlist + :exited-non-locally))))))) + allegro-spec)) + +(defimplementation unwrap (spec indicator) + (let ((allegro-spec (process-fspec-for-allegro spec))) + (excl:funwrap allegro-spec indicator) + allegro-spec)) + +(defimplementation wrapped-p (spec indicator) + (getf (excl:fwrap-order (process-fspec-for-allegro spec)) indicator)) diff --git a/vim/bundle/slimv/slime/swank/backend.lisp b/vim/bundle/slimv/slime/swank/backend.lisp new file mode 100644 index 0000000..81023df --- /dev/null +++ b/vim/bundle/slimv/slime/swank/backend.lisp @@ -0,0 +1,1536 @@ +;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;*" -*- +;;; +;;; slime-backend.lisp --- SLIME backend interface. +;;; +;;; Created by James Bielman in 2003. Released into the public domain. +;;; +;;;; Frontmatter +;;; +;;; This file defines the functions that must be implemented +;;; separately for each Lisp. Each is declared as a generic function +;;; for which swank-<implementation>.lisp provides methods. + +(in-package swank/backend) + + +;;;; Metacode + +(defparameter *debug-swank-backend* nil + "If this is true, backends should not catch errors but enter the +debugger where appropriate. Also, they should not perform backtrace +magic but really show every frame including SWANK related ones.") + +(defparameter *interface-functions* '() + "The names of all interface functions.") + +(defparameter *unimplemented-interfaces* '() + "List of interface functions that are not implemented. +DEFINTERFACE adds to this list and DEFIMPLEMENTATION removes.") + +(defvar *log-output* nil) ; should be nil for image dumpers + +(defmacro definterface (name args documentation &rest default-body) + "Define an interface function for the backend to implement. +A function is defined with NAME, ARGS, and DOCUMENTATION. This +function first looks for a function to call in NAME's property list +that is indicated by 'IMPLEMENTATION; failing that, it looks for a +function indicated by 'DEFAULT. If neither is present, an error is +signaled. + +If a DEFAULT-BODY is supplied, then a function with the same body and +ARGS will be added to NAME's property list as the property indicated +by 'DEFAULT. + +Backends implement these functions using DEFIMPLEMENTATION." + (check-type documentation string "a documentation string") + (assert (every #'symbolp args) () + "Complex lambda-list not supported: ~S ~S" name args) + (labels ((gen-default-impl () + `(setf (get ',name 'default) (lambda ,args ,@default-body))) + (args-as-list (args) + (destructuring-bind (req opt key rest) (parse-lambda-list args) + `(,@req ,@opt + ,@(loop for k in key append `(,(kw k) ,k)) + ,@(or rest '(()))))) + (parse-lambda-list (args) + (parse args '(&optional &key &rest) + (make-array 4 :initial-element nil))) + (parse (args keywords vars) + (cond ((null args) + (reverse (map 'list #'reverse vars))) + ((member (car args) keywords) + (parse (cdr args) (cdr (member (car args) keywords)) vars)) + (t (push (car args) (aref vars (length keywords))) + (parse (cdr args) keywords vars)))) + (kw (s) (intern (string s) :keyword))) + `(progn + (defun ,name ,args + ,documentation + (let ((f (or (get ',name 'implementation) + (get ',name 'default)))) + (cond (f (apply f ,@(args-as-list args))) + (t (error "~S not implemented" ',name))))) + (pushnew ',name *interface-functions*) + ,(if (null default-body) + `(pushnew ',name *unimplemented-interfaces*) + (gen-default-impl)) + (eval-when (:compile-toplevel :load-toplevel :execute) + (export ',name :swank/backend)) + ',name))) + +(defmacro defimplementation (name args &body body) + (assert (every #'symbolp args) () + "Complex lambda-list not supported: ~S ~S" name args) + `(progn + (setf (get ',name 'implementation) + ;; For implicit BLOCK. FLET because of interplay w/ decls. + (flet ((,name ,args ,@body)) #',name)) + (if (member ',name *interface-functions*) + (setq *unimplemented-interfaces* + (remove ',name *unimplemented-interfaces*)) + (warn "DEFIMPLEMENTATION of undefined interface (~S)" ',name)) + ',name)) + +(defun warn-unimplemented-interfaces () + "Warn the user about unimplemented backend features. +The portable code calls this function at startup." + (let ((*print-pretty* t)) + (warn "These Swank interfaces are unimplemented:~% ~:<~{~A~^ ~:_~}~:>" + (list (sort (copy-list *unimplemented-interfaces*) #'string<))))) + +(defun import-to-swank-mop (symbol-list) + (dolist (sym symbol-list) + (let* ((swank-mop-sym (find-symbol (symbol-name sym) :swank-mop))) + (when swank-mop-sym + (unintern swank-mop-sym :swank-mop)) + (import sym :swank-mop) + (export sym :swank-mop)))) + +(defun import-swank-mop-symbols (package except) + "Import the mop symbols from PACKAGE to SWANK-MOP. +EXCEPT is a list of symbol names which should be ignored." + (do-symbols (s :swank-mop) + (unless (member s except :test #'string=) + (let ((real-symbol (find-symbol (string s) package))) + (assert real-symbol () "Symbol ~A not found in package ~A" s package) + (unintern s :swank-mop) + (import real-symbol :swank-mop) + (export real-symbol :swank-mop))))) + +(definterface gray-package-name () + "Return a package-name that contains the Gray stream symbols. +This will be used like so: + (defpackage foo + (:import-from #.(gray-package-name) . #.*gray-stream-symbols*)") + + +;;;; Utilities + +(defmacro with-struct ((conc-name &rest names) obj &body body) + "Like with-slots but works only for structs." + (check-type conc-name symbol) + (flet ((reader (slot) + (intern (concatenate 'string + (symbol-name conc-name) + (symbol-name slot)) + (symbol-package conc-name)))) + (let ((tmp (gensym "OO-"))) + ` (let ((,tmp ,obj)) + (symbol-macrolet + ,(loop for name in names collect + (typecase name + (symbol `(,name (,(reader name) ,tmp))) + (cons `(,(first name) (,(reader (second name)) ,tmp))) + (t (error "Malformed syntax in WITH-STRUCT: ~A" name)))) + ,@body))))) + +(defmacro when-let ((var value) &body body) + `(let ((,var ,value)) + (when ,var ,@body))) + +(defun boolean-to-feature-expression (value) + "Converts a boolean VALUE to a form suitable for testing with #+." + (if value + '(:and) + '(:or))) + +(defun with-symbol (name package) + "Check if a symbol with a given NAME exists in PACKAGE and returns a +form suitable for testing with #+." + (boolean-to-feature-expression + (and (find-package package) + (find-symbol (string name) package)))) + +(defun choose-symbol (package name alt-package alt-name) + "If symbol package:name exists return that symbol, otherwise alt-package:alt-name. + Suitable for use with #." + (or (and (find-package package) + (find-symbol (string name) package)) + (find-symbol (string alt-name) alt-package))) + + +;;;; UFT8 + +(deftype octet () '(unsigned-byte 8)) +(deftype octets () '(simple-array octet (*))) + +;; Helper function. Decode the next N bytes starting from INDEX. +;; Return the decoded char and the new index. +(defun utf8-decode-aux (buffer index limit byte0 n) + (declare (type octets buffer) (fixnum index limit byte0 n)) + (if (< (- limit index) n) + (values nil index) + (do ((i 0 (1+ i)) + (code byte0 (let ((byte (aref buffer (+ index i)))) + (cond ((= (ldb (byte 2 6) byte) #b10) + (+ (ash code 6) (ldb (byte 6 0) byte))) + (t + (error "Invalid encoding")))))) + ((= i n) + (values (cond ((<= code #xff) (code-char code)) + ((<= #xd800 code #xdfff) + (error "Invalid Unicode code point: #x~x" code)) + ((and (< code char-code-limit) + (code-char code))) + (t + (error + "Can't represent code point: #x~x ~ + (char-code-limit is #x~x)" + code char-code-limit))) + (+ index n)))))) + +;; Decode one character in BUFFER starting at INDEX. +;; Return 2 values: the character and the new index. +;; If there aren't enough bytes between INDEX and LIMIT return nil. +(defun utf8-decode (buffer index limit) + (declare (type octets buffer) (fixnum index limit)) + (if (= index limit) + (values nil index) + (let ((b (aref buffer index))) + (if (<= b #x7f) + (values (code-char b) (1+ index)) + (macrolet ((try (marker else) + (let* ((l (integer-length marker)) + (n (- l 2))) + `(if (= (ldb (byte ,l ,(- 8 l)) b) ,marker) + (utf8-decode-aux buffer (1+ index) limit + (ldb (byte ,(- 8 l) 0) b) + ,n) + ,else)))) + (try #b110 + (try #b1110 + (try #b11110 + (try #b111110 + (try #b1111110 + (error "Invalid encoding"))))))))))) + +;; Decode characters from BUFFER and write them to STRING. +;; Return 2 values: LASTINDEX and LASTSTART where +;; LASTINDEX is the last index in BUFFER that was not decoded +;; and LASTSTART is the last index in STRING not written. +(defun utf8-decode-into (buffer index limit string start end) + (declare (string string) (fixnum index limit start end) (type octets buffer)) + (loop + (cond ((= start end) + (return (values index start))) + (t + (multiple-value-bind (c i) (utf8-decode buffer index limit) + (cond (c + (setf (aref string start) c) + (setq index i) + (setq start (1+ start))) + (t + (return (values index start))))))))) + +(defun default-utf8-to-string (octets) + (let* ((limit (length octets)) + (str (make-string limit))) + (multiple-value-bind (i s) (utf8-decode-into octets 0 limit str 0 limit) + (if (= i limit) + (if (= limit s) + str + (adjust-array str s)) + (loop + (let ((end (+ (length str) (- limit i)))) + (setq str (adjust-array str end)) + (multiple-value-bind (i2 s2) + (utf8-decode-into octets i limit str s end) + (cond ((= i2 limit) + (return (adjust-array str s2))) + (t + (setq i i2) + (setq s s2)))))))))) + +(defmacro utf8-encode-aux (code buffer start end n) + `(cond ((< (- ,end ,start) ,n) + ,start) + (t + (setf (aref ,buffer ,start) + (dpb (ldb (byte ,(- 7 n) ,(* 6 (1- n))) ,code) + (byte ,(- 7 n) 0) + ,(dpb 0 (byte 1 (- 7 n)) #xff))) + ,@(loop for i from 0 upto (- n 2) collect + `(setf (aref ,buffer (+ ,start ,(- n 1 i))) + (dpb (ldb (byte 6 ,(* 6 i)) ,code) + (byte 6 0) + #b10111111))) + (+ ,start ,n)))) + +(defun %utf8-encode (code buffer start end) + (declare (type (unsigned-byte 31) code) (type octets buffer) + (type (and fixnum unsigned-byte) start end)) + (cond ((<= code #x7f) + (cond ((< start end) + (setf (aref buffer start) code) + (1+ start)) + (t start))) + ((<= code #x7ff) (utf8-encode-aux code buffer start end 2)) + ((<= #xd800 code #xdfff) + (error "Invalid Unicode code point (surrogate): #x~x" code)) + ((<= code #xffff) (utf8-encode-aux code buffer start end 3)) + ((<= code #x1fffff) (utf8-encode-aux code buffer start end 4)) + ((<= code #x3ffffff) (utf8-encode-aux code buffer start end 5)) + (t (utf8-encode-aux code buffer start end 6)))) + +(defun utf8-encode (char buffer start end) + (declare (type character char) (type octets buffer) + (type (and fixnum unsigned-byte) start end)) + (%utf8-encode (char-code char) buffer start end)) + +(defun utf8-encode-into (string start end buffer index limit) + (declare (string string) (type octets buffer) (fixnum start end index limit)) + (loop + (cond ((= start end) + (return (values start index))) + ((= index limit) + (return (values start index))) + (t + (let ((i2 (utf8-encode (char string start) buffer index limit))) + (cond ((= i2 index) + (return (values start index))) + (t + (setq index i2) + (incf start)))))))) + +(defun default-string-to-utf8 (string) + (let* ((len (length string)) + (b (make-array len :element-type 'octet))) + (multiple-value-bind (s i) (utf8-encode-into string 0 len b 0 len) + (if (= s len) + b + (loop + (let ((limit (+ (length b) (- len s)))) + (setq b (coerce (adjust-array b limit) 'octets)) + (multiple-value-bind (s2 i2) + (utf8-encode-into string s len b i limit) + (cond ((= s2 len) + (return (coerce (adjust-array b i2) 'octets))) + (t + (setq i i2) + (setq s s2)))))))))) + +(definterface string-to-utf8 (string) + "Convert the string STRING to a (simple-array (unsigned-byte 8))" + (default-string-to-utf8 string)) + +(definterface utf8-to-string (octets) + "Convert the (simple-array (unsigned-byte 8)) OCTETS to a string." + (default-utf8-to-string octets)) + + +;;;; TCP server + +(definterface create-socket (host port &key backlog) + "Create a listening TCP socket on interface HOST and port PORT. +BACKLOG queue length for incoming connections.") + +(definterface local-port (socket) + "Return the local port number of SOCKET.") + +(definterface close-socket (socket) + "Close the socket SOCKET.") + +(definterface accept-connection (socket &key external-format + buffering timeout) + "Accept a client connection on the listening socket SOCKET. +Return a stream for the new connection. +If EXTERNAL-FORMAT is nil return a binary stream +otherwise create a character stream. +BUFFERING can be one of: + nil ... no buffering + t ... enable buffering + :line ... enable buffering with automatic flushing on eol.") + +(definterface add-sigio-handler (socket fn) + "Call FN whenever SOCKET is readable.") + +(definterface remove-sigio-handlers (socket) + "Remove all sigio handlers for SOCKET.") + +(definterface add-fd-handler (socket fn) + "Call FN when Lisp is waiting for input and SOCKET is readable.") + +(definterface remove-fd-handlers (socket) + "Remove all fd-handlers for SOCKET.") + +(definterface preferred-communication-style () + "Return one of the symbols :spawn, :sigio, :fd-handler, or NIL." + nil) + +(definterface set-stream-timeout (stream timeout) + "Set the 'stream 'timeout. The timeout is either the real number + specifying the timeout in seconds or 'nil for no timeout." + (declare (ignore stream timeout)) + nil) + +;;; Base condition for networking errors. +(define-condition network-error (simple-error) ()) + +(definterface emacs-connected () + "Hook called when the first connection from Emacs is established. +Called from the INIT-FN of the socket server that accepts the +connection. + +This is intended for setting up extra context, e.g. to discover +that the calling thread is the one that interacts with Emacs." + nil) + + +;;;; Unix signals + +(defconstant +sigint+ 2) + +(definterface getpid () + "Return the (Unix) process ID of this superior Lisp.") + +(definterface install-sigint-handler (function) + "Call FUNCTION on SIGINT (instead of invoking the debugger). +Return old signal handler." + (declare (ignore function)) + nil) + +(definterface call-with-user-break-handler (handler function) + "Install the break handler HANDLER while executing FUNCTION." + (let ((old-handler (install-sigint-handler handler))) + (unwind-protect (funcall function) + (install-sigint-handler old-handler)))) + +(definterface quit-lisp () + "Exit the current lisp image.") + +(definterface lisp-implementation-type-name () + "Return a short name for the Lisp implementation." + (lisp-implementation-type)) + +(definterface lisp-implementation-program () + "Return the argv[0] of the running Lisp process, or NIL." + (let ((file (car (command-line-args)))) + (when (and file (probe-file file)) + (namestring (truename file))))) + +(definterface socket-fd (socket-stream) + "Return the file descriptor for SOCKET-STREAM.") + +(definterface make-fd-stream (fd external-format) + "Create a character stream for the file descriptor FD.") + +(definterface dup (fd) + "Duplicate a file descriptor. +If the syscall fails, signal a condition. +See dup(2).") + +(definterface exec-image (image-file args) + "Replace the current process with a new process image. +The new image is created by loading the previously dumped +core file IMAGE-FILE. +ARGS is a list of strings passed as arguments to +the new image. +This is thin wrapper around exec(3).") + +(definterface command-line-args () + "Return a list of strings as passed by the OS." + nil) + + +;; pathnames are sooo useless + +(definterface filename-to-pathname (filename) + "Return a pathname for FILENAME. +A filename in Emacs may for example contain asterisks which should not +be translated to wildcards." + (parse-namestring filename)) + +(definterface pathname-to-filename (pathname) + "Return the filename for PATHNAME." + (namestring pathname)) + +(definterface default-directory () + "Return the default directory." + (directory-namestring (truename *default-pathname-defaults*))) + +(definterface set-default-directory (directory) + "Set the default directory. +This is used to resolve filenames without directory component." + (setf *default-pathname-defaults* (truename (merge-pathnames directory))) + (default-directory)) + + +(definterface call-with-syntax-hooks (fn) + "Call FN with hooks to handle special syntax." + (funcall fn)) + +(definterface default-readtable-alist () + "Return a suitable initial value for SWANK:*READTABLE-ALIST*." + '()) + + +;;;; Packages + +(definterface package-local-nicknames (package) + "Returns an alist of (local-nickname . actual-package) describing the +nicknames local to the designated package." + (declare (ignore package)) + nil) + +(definterface find-locally-nicknamed-package (name base-package) + "Return the package whose local nickname in BASE-PACKAGE matches NAME. +Return NIL if local nicknames are not implemented or if there is no +such package." + (cdr (assoc name (package-local-nicknames base-package) :test #'string-equal))) + + +;;;; Compilation + +(definterface call-with-compilation-hooks (func) + "Call FUNC with hooks to record compiler conditions.") + +(defmacro with-compilation-hooks ((&rest ignore) &body body) + "Execute BODY as in CALL-WITH-COMPILATION-HOOKS." + (declare (ignore ignore)) + `(call-with-compilation-hooks (lambda () (progn ,@body)))) + +(definterface swank-compile-string (string &key buffer position filename + policy) + "Compile source from STRING. +During compilation, compiler conditions must be trapped and +resignalled as COMPILER-CONDITIONs. + +If supplied, BUFFER and POSITION specify the source location in Emacs. + +Additionally, if POSITION is supplied, it must be added to source +positions reported in compiler conditions. + +If FILENAME is specified it may be used by certain implementations to +rebind *DEFAULT-PATHNAME-DEFAULTS* which may improve the recording of +source information. + +If POLICY is supplied, and non-NIL, it may be used by certain +implementations to compile with optimization qualities of its +value. + +Should return T on successful compilation, NIL otherwise. +") + +(definterface swank-compile-file (input-file output-file load-p + external-format + &key policy) + "Compile INPUT-FILE signalling COMPILE-CONDITIONs. +If LOAD-P is true, load the file after compilation. +EXTERNAL-FORMAT is a value returned by find-external-format or +:default. + +If POLICY is supplied, and non-NIL, it may be used by certain +implementations to compile with optimization qualities of its +value. + +Should return OUTPUT-TRUENAME, WARNINGS-P and FAILURE-p +like `compile-file'") + +(deftype severity () + '(member :error :read-error :warning :style-warning :note :redefinition)) + +;; Base condition type for compiler errors, warnings and notes. +(define-condition compiler-condition (condition) + ((original-condition + ;; The original condition thrown by the compiler if appropriate. + ;; May be NIL if a compiler does not report using conditions. + :type (or null condition) + :initarg :original-condition + :accessor original-condition) + + (severity :type severity + :initarg :severity + :accessor severity) + + (message :initarg :message + :accessor message) + + ;; Macro expansion history etc. which may be helpful in some cases + ;; but is often very verbose. + (source-context :initarg :source-context + :type (or null string) + :initform nil + :accessor source-context) + + (references :initarg :references + :initform nil + :accessor references) + + (location :initarg :location + :accessor location))) + +(definterface find-external-format (coding-system) + "Return a \"external file format designator\" for CODING-SYSTEM. +CODING-SYSTEM is Emacs-style coding system name (a string), +e.g. \"latin-1-unix\"." + (if (equal coding-system "iso-latin-1-unix") + :default + nil)) + +(definterface guess-external-format (pathname) + "Detect the external format for the file with name pathname. +Return nil if the file contains no special markers." + ;; Look for a Emacs-style -*- coding: ... -*- or Local Variable: section. + (with-open-file (s pathname :if-does-not-exist nil + :external-format (or (find-external-format "latin-1-unix") + :default)) + (if s + (or (let* ((line (read-line s nil)) + (p (search "-*-" line))) + (when p + (let* ((start (+ p (length "-*-"))) + (end (search "-*-" line :start2 start))) + (when end + (%search-coding line start end))))) + (let* ((len (file-length s)) + (buf (make-string (min len 3000)))) + (file-position s (- len (length buf))) + (read-sequence buf s) + (let ((start (search "Local Variables:" buf :from-end t)) + (end (search "End:" buf :from-end t))) + (and start end (< start end) + (%search-coding buf start end)))))))) + +(defun %search-coding (str start end) + (let ((p (search "coding:" str :start2 start :end2 end))) + (when p + (incf p (length "coding:")) + (loop while (and (< p end) + (member (aref str p) '(#\space #\tab))) + do (incf p)) + (let ((end (position-if (lambda (c) (find c '(#\space #\tab #\newline))) + str :start p))) + (find-external-format (subseq str p end)))))) + + +;;;; Streams + +(definterface make-output-stream (write-string) + "Return a new character output stream. +The stream calls WRITE-STRING when output is ready.") + +(definterface make-input-stream (read-string) + "Return a new character input stream. +The stream calls READ-STRING when input is needed.") + + +;;;; Documentation + +(definterface arglist (name) + "Return the lambda list for the symbol NAME. NAME can also be +a lisp function object, on lisps which support this. + +The result can be a list or the :not-available keyword if the +arglist cannot be determined." + (declare (ignore name)) + :not-available) + +(defgeneric declaration-arglist (decl-identifier) + (:documentation + "Return the argument list of the declaration specifier belonging to the +declaration identifier DECL-IDENTIFIER. If the arglist cannot be determined, +the keyword :NOT-AVAILABLE is returned. + +The different SWANK backends can specialize this generic function to +include implementation-dependend declaration specifiers, or to provide +additional information on the specifiers defined in ANSI Common Lisp.") + (:method (decl-identifier) + (case decl-identifier + (dynamic-extent '(&rest variables)) + (ignore '(&rest variables)) + (ignorable '(&rest variables)) + (special '(&rest variables)) + (inline '(&rest function-names)) + (notinline '(&rest function-names)) + (declaration '(&rest names)) + (optimize '(&any compilation-speed debug safety space speed)) + (type '(type-specifier &rest args)) + (ftype '(type-specifier &rest function-names)) + (otherwise + (flet ((typespec-p (symbol) + (member :type (describe-symbol-for-emacs symbol)))) + (cond ((and (symbolp decl-identifier) (typespec-p decl-identifier)) + '(&rest variables)) + ((and (listp decl-identifier) + (typespec-p (first decl-identifier))) + '(&rest variables)) + (t :not-available))))))) + +(defgeneric type-specifier-arglist (typespec-operator) + (:documentation + "Return the argument list of the type specifier belonging to +TYPESPEC-OPERATOR.. If the arglist cannot be determined, the keyword +:NOT-AVAILABLE is returned. + +The different SWANK backends can specialize this generic function to +include implementation-dependend declaration specifiers, or to provide +additional information on the specifiers defined in ANSI Common Lisp.") + (:method (typespec-operator) + (declare (special *type-specifier-arglists*)) ; defined at end of file. + (typecase typespec-operator + (symbol (or (cdr (assoc typespec-operator *type-specifier-arglists*)) + :not-available)) + (t :not-available)))) + +(definterface type-specifier-p (symbol) + "Determine if SYMBOL is a type-specifier." + (or (documentation symbol 'type) + (not (eq (type-specifier-arglist symbol) :not-available)))) + +(definterface function-name (function) + "Return the name of the function object FUNCTION. + +The result is either a symbol, a list, or NIL if no function name is +available." + (declare (ignore function)) + nil) + +(definterface valid-function-name-p (form) + "Is FORM syntactically valid to name a function? + If true, FBOUNDP should not signal a type-error for FORM." + (flet ((length=2 (list) + (and (not (null (cdr list))) (null (cddr list))))) + (or (symbolp form) + (and (consp form) (length=2 form) + (eq (first form) 'setf) (symbolp (second form)))))) + +(definterface macroexpand-all (form &optional env) + "Recursively expand all macros in FORM. +Return the resulting form.") + +(definterface compiler-macroexpand-1 (form &optional env) + "Call the compiler-macro for form. +If FORM is a function call for which a compiler-macro has been +defined, invoke the expander function using *macroexpand-hook* and +return the results and T. Otherwise, return the original form and +NIL." + (let ((fun (and (consp form) + (valid-function-name-p (car form)) + (compiler-macro-function (car form) env)))) + (if fun + (let ((result (funcall *macroexpand-hook* fun form env))) + (values result (not (eq result form)))) + (values form nil)))) + +(definterface compiler-macroexpand (form &optional env) + "Repetitively call `compiler-macroexpand-1'." + (labels ((frob (form expanded) + (multiple-value-bind (new-form newly-expanded) + (compiler-macroexpand-1 form env) + (if newly-expanded + (frob new-form t) + (values new-form expanded))))) + (frob form env))) + +(defmacro with-collected-macro-forms + ((forms &optional result) instrumented-form &body body) + "Collect macro forms by locally binding *MACROEXPAND-HOOK*. + +Evaluates INSTRUMENTED-FORM and collects any forms which undergo +macro-expansion into a list. Then evaluates BODY with FORMS bound to +the list of forms, and RESULT (optionally) bound to the value of +INSTRUMENTED-FORM." + (assert (and (symbolp forms) (not (null forms)))) + (assert (symbolp result)) + (let ((result-symbol (or result (gensym)))) + `(call-with-collected-macro-forms + (lambda (,forms ,result-symbol) + (declare (ignore ,@(and (not result) + `(,result-symbol)))) + ,@body) + (lambda () ,instrumented-form)))) + +(defun call-with-collected-macro-forms (body-fn instrumented-fn) + (let ((return-value nil) + (collected-forms '())) + (let* ((real-macroexpand-hook *macroexpand-hook*) + (*macroexpand-hook* + (lambda (macro-function form environment) + (let ((result (funcall real-macroexpand-hook + macro-function form environment))) + (unless (eq result form) + (push form collected-forms)) + result)))) + (setf return-value (funcall instrumented-fn))) + (funcall body-fn collected-forms return-value))) + +(definterface collect-macro-forms (form &optional env) + "Collect subforms of FORM which undergo (compiler-)macro expansion. +Returns two values: a list of macro forms and a list of compiler macro +forms." + (with-collected-macro-forms (macro-forms expansion) + (ignore-errors (macroexpand-all form env)) + (with-collected-macro-forms (compiler-macro-forms) + (handler-bind ((warning #'muffle-warning)) + (ignore-errors + (compile nil `(lambda () ,expansion)))) + (values macro-forms compiler-macro-forms)))) + +(definterface format-string-expand (control-string) + "Expand the format string CONTROL-STRING." + (macroexpand `(formatter ,control-string))) + +(definterface describe-symbol-for-emacs (symbol) + "Return a property list describing SYMBOL. + +The property list has an entry for each interesting aspect of the +symbol. The recognised keys are: + + :VARIABLE :FUNCTION :SETF :SPECIAL-OPERATOR :MACRO :COMPILER-MACRO + :TYPE :CLASS :ALIEN-TYPE :ALIEN-STRUCT :ALIEN-UNION :ALIEN-ENUM + +The value of each property is the corresponding documentation string, +or NIL (or the obsolete :NOT-DOCUMENTED). It is legal to include keys +not listed here (but slime-print-apropos in Emacs must know about +them). + +Properties should be included if and only if they are applicable to +the symbol. For example, only (and all) fbound symbols should include +the :FUNCTION property. + +Example: +\(describe-symbol-for-emacs 'vector) + => (:CLASS :NOT-DOCUMENTED + :TYPE :NOT-DOCUMENTED + :FUNCTION \"Constructs a simple-vector from the given objects.\")") + +(definterface describe-definition (name type) + "Describe the definition NAME of TYPE. +TYPE can be any value returned by DESCRIBE-SYMBOL-FOR-EMACS. + +Return a documentation string, or NIL if none is available.") + + +;;;; Debugging + +(definterface install-debugger-globally (function) + "Install FUNCTION as the debugger for all threads/processes. This +usually involves setting *DEBUGGER-HOOK* and, if the implementation +permits, hooking into BREAK as well." + (setq *debugger-hook* function)) + +(definterface call-with-debugging-environment (debugger-loop-fn) + "Call DEBUGGER-LOOP-FN in a suitable debugging environment. + +This function is called recursively at each debug level to invoke the +debugger loop. The purpose is to setup any necessary environment for +other debugger callbacks that will be called within the debugger loop. + +For example, this is a reasonable place to compute a backtrace, switch +to safe reader/printer settings, and so on.") + +(definterface call-with-debugger-hook (hook fun) + "Call FUN and use HOOK as debugger hook. HOOK can be NIL. + +HOOK should be called for both BREAK and INVOKE-DEBUGGER." + (let ((*debugger-hook* hook)) + (funcall fun))) + +(define-condition sldb-condition (condition) + ((original-condition + :initarg :original-condition + :accessor original-condition)) + (:report (lambda (condition stream) + (format stream "Condition in debugger code~@[: ~A~]" + (original-condition condition)))) + (:documentation + "Wrapper for conditions that should not be debugged. + +When a condition arises from the internals of the debugger, it is not +desirable to debug it -- we'd risk entering an endless loop trying to +debug the debugger! Instead, such conditions can be reported to the +user without (re)entering the debugger by wrapping them as +`sldb-condition's.")) + +;;; The following functions in this section are supposed to be called +;;; within the dynamic contour of CALL-WITH-DEBUGGING-ENVIRONMENT only. + +(definterface compute-backtrace (start end) + "Returns a backtrace of the condition currently being debugged, +that is an ordered list consisting of frames. ``Ordered list'' +means that an integer I can be mapped back to the i-th frame of this +backtrace. + +START and END are zero-based indices constraining the number of frames +returned. Frame zero is defined as the frame which invoked the +debugger. If END is nil, return the frames from START to the end of +the stack.") + +(definterface print-frame (frame stream) + "Print frame to stream.") + +(definterface frame-restartable-p (frame) + "Is the frame FRAME restartable?. +Return T if `restart-frame' can safely be called on the frame." + (declare (ignore frame)) + nil) + +(definterface frame-source-location (frame-number) + "Return the source location for the frame associated to FRAME-NUMBER.") + +(definterface frame-catch-tags (frame-number) + "Return a list of catch tags for being printed in a debugger stack +frame." + (declare (ignore frame-number)) + '()) + +(definterface frame-locals (frame-number) + "Return a list of ((&key NAME ID VALUE) ...) where each element of +the list represents a local variable in the stack frame associated to +FRAME-NUMBER. + +NAME, a symbol; the name of the local variable. + +ID, an integer; used as primary key for the local variable, unique +relatively to the frame under operation. + +value, an object; the value of the local variable.") + +(definterface frame-var-value (frame-number var-id) + "Return the value of the local variable associated to VAR-ID +relatively to the frame associated to FRAME-NUMBER.") + +(definterface disassemble-frame (frame-number) + "Disassemble the code for the FRAME-NUMBER. +The output should be written to standard output. +FRAME-NUMBER is a non-negative integer.") + +(definterface eval-in-frame (form frame-number) + "Evaluate a Lisp form in the lexical context of a stack frame +in the debugger. + +FRAME-NUMBER must be a positive integer with 0 indicating the +frame which invoked the debugger. + +The return value is the result of evaulating FORM in the +appropriate context.") + +(definterface frame-package (frame-number) + "Return the package corresponding to the frame at FRAME-NUMBER. +Return nil if the backend can't figure it out." + (declare (ignore frame-number)) + nil) + +(definterface frame-call (frame-number) + "Return a string representing a call to the entry point of a frame.") + +(definterface return-from-frame (frame-number form) + "Unwind the stack to the frame FRAME-NUMBER and return the value(s) +produced by evaluating FORM in the frame context to its caller. + +Execute any clean-up code from unwind-protect forms above the frame +during unwinding. + +Return a string describing the error if it's not possible to return +from the frame.") + +(definterface restart-frame (frame-number) + "Restart execution of the frame FRAME-NUMBER with the same arguments +as it was called originally.") + +(definterface print-condition (condition stream) + "Print a condition for display in SLDB." + (princ condition stream)) + +(definterface condition-extras (condition) + "Return a list of extra for the debugger. +The allowed elements are of the form: + (:SHOW-FRAME-SOURCE frame-number) + (:REFERENCES &rest refs) +" + (declare (ignore condition)) + '()) + +(definterface gdb-initial-commands () + "List of gdb commands supposed to be executed first for the + ATTACH-GDB restart." + nil) + +(definterface activate-stepping (frame-number) + "Prepare the frame FRAME-NUMBER for stepping.") + +(definterface sldb-break-on-return (frame-number) + "Set a breakpoint in the frame FRAME-NUMBER.") + +(definterface sldb-break-at-start (symbol) + "Set a breakpoint on the beginning of the function for SYMBOL.") + +(definterface sldb-stepper-condition-p (condition) + "Return true if SLDB was invoked due to a single-stepping condition, +false otherwise. " + (declare (ignore condition)) + nil) + +(definterface sldb-step-into () + "Step into the current single-stepper form.") + +(definterface sldb-step-next () + "Step to the next form in the current function.") + +(definterface sldb-step-out () + "Stop single-stepping temporarily, but resume it once the current function +returns.") + + +;;;; Definition finding + +(defstruct (:location (:type list) :named + (:constructor make-location + (buffer position &optional hints))) + buffer position + ;; Hints is a property list optionally containing: + ;; :snippet SOURCE-TEXT + ;; This is a snippet of the actual source text at the start of + ;; the definition, which could be used in a text search. + hints) + +(defstruct (:error (:type list) :named (:constructor)) message) + +;;; Valid content for BUFFER slot +(defstruct (:file (:type list) :named (:constructor)) name) +(defstruct (:buffer (:type list) :named (:constructor)) name) +(defstruct (:etags-file (:type list) :named (:constructor)) filename) + +;;; Valid content for POSITION slot +(defstruct (:position (:type list) :named (:constructor)) pos) +(defstruct (:tag (:type list) :named (:constructor)) tag1 tag2) + +(defmacro converting-errors-to-error-location (&body body) + "Catches errors during BODY and converts them to an error location." + (let ((gblock (gensym "CONVERTING-ERRORS+"))) + `(block ,gblock + (handler-bind ((error + #'(lambda (e) + (if *debug-swank-backend* + nil ;decline + (return-from ,gblock + (make-error-location e)))))) + ,@body)))) + +(defun make-error-location (datum &rest args) + (cond ((typep datum 'condition) + `(:error ,(format nil "Error: ~A" datum))) + ((symbolp datum) + `(:error ,(format nil "Error: ~A" + (apply #'make-condition datum args)))) + (t + (assert (stringp datum)) + `(:error ,(apply #'format nil datum args))))) + +(definterface find-definitions (name) + "Return a list ((DSPEC LOCATION) ...) for NAME's definitions. + +NAME is a \"definition specifier\". + +DSPEC is a \"definition specifier\" describing the +definition, e.g., FOO or (METHOD FOO (STRING NUMBER)) or +\(DEFVAR FOO). + +LOCATION is the source location for the definition.") + +(definterface find-source-location (object) + "Returns the source location of OBJECT, or NIL. + +That is the source location of the underlying datastructure of +OBJECT. E.g. on a STANDARD-OBJECT, the source location of the +respective DEFCLASS definition is returned, on a STRUCTURE-CLASS the +respective DEFSTRUCT definition, and so on." + ;; This returns one source location and not a list of locations. It's + ;; supposed to return the location of the DEFGENERIC definition on + ;; #'SOME-GENERIC-FUNCTION. + (declare (ignore object)) + (make-error-location "FIND-SOURCE-LOCATION is not yet implemented on ~ + this implementation.")) + +(definterface buffer-first-change (filename) + "Called for effect the first time FILENAME's buffer is modified. +CMUCL/SBCL use this to cache the unmodified file and use the +unmodified text to improve the precision of source locations." + (declare (ignore filename)) + nil) + + + +;;;; XREF + +(definterface who-calls (function-name) + "Return the call sites of FUNCTION-NAME (a symbol). +The results is a list ((DSPEC LOCATION) ...)." + (declare (ignore function-name)) + :not-implemented) + +(definterface calls-who (function-name) + "Return the call sites of FUNCTION-NAME (a symbol). +The results is a list ((DSPEC LOCATION) ...)." + (declare (ignore function-name)) + :not-implemented) + +(definterface who-references (variable-name) + "Return the locations where VARIABLE-NAME (a symbol) is referenced. +See WHO-CALLS for a description of the return value." + (declare (ignore variable-name)) + :not-implemented) + +(definterface who-binds (variable-name) + "Return the locations where VARIABLE-NAME (a symbol) is bound. +See WHO-CALLS for a description of the return value." + (declare (ignore variable-name)) + :not-implemented) + +(definterface who-sets (variable-name) + "Return the locations where VARIABLE-NAME (a symbol) is set. +See WHO-CALLS for a description of the return value." + (declare (ignore variable-name)) + :not-implemented) + +(definterface who-macroexpands (macro-name) + "Return the locations where MACRO-NAME (a symbol) is expanded. +See WHO-CALLS for a description of the return value." + (declare (ignore macro-name)) + :not-implemented) + +(definterface who-specializes (class-name) + "Return the locations where CLASS-NAME (a symbol) is specialized. +See WHO-CALLS for a description of the return value." + (declare (ignore class-name)) + :not-implemented) + +;;; Simpler variants. + +(definterface list-callers (function-name) + "List the callers of FUNCTION-NAME. +This function is like WHO-CALLS except that it is expected to use +lower-level means. Whereas WHO-CALLS is usually implemented with +special compiler support, LIST-CALLERS is usually implemented by +groveling for constants in function objects throughout the heap. + +The return value is as for WHO-CALLS.") + +(definterface list-callees (function-name) + "List the functions called by FUNCTION-NAME. +See LIST-CALLERS for a description of the return value.") + + +;;;; Profiling + +;;; The following functions define a minimal profiling interface. + +(definterface profile (fname) + "Marks symbol FNAME for profiling.") + +(definterface profiled-functions () + "Returns a list of profiled functions.") + +(definterface unprofile (fname) + "Marks symbol FNAME as not profiled.") + +(definterface unprofile-all () + "Marks all currently profiled functions as not profiled." + (dolist (f (profiled-functions)) + (unprofile f))) + +(definterface profile-report () + "Prints profile report.") + +(definterface profile-reset () + "Resets profile counters.") + +(definterface profile-package (package callers-p methods) + "Wrap profiling code around all functions in PACKAGE. If a function +is already profiled, then unprofile and reprofile (useful to notice +function redefinition.) + +If CALLERS-P is T names have counts of the most common calling +functions recorded. + +When called with arguments :METHODS T, profile all methods of all +generic functions having names in the given package. Generic functions +themselves, that is, their dispatch functions, are left alone.") + + +;;;; Trace + +(definterface toggle-trace (spec) + "Toggle tracing of the function(s) given with SPEC. +SPEC can be: + (setf NAME) ; a setf function + (:defmethod NAME QUALIFIER... (SPECIALIZER...)) ; a specific method + (:defgeneric NAME) ; a generic function with all methods + (:call CALLER CALLEE) ; trace calls from CALLER to CALLEE. + (:labels TOPLEVEL LOCAL) + (:flet TOPLEVEL LOCAL) ") + + +;;;; Inspector + +(defgeneric emacs-inspect (object) + (:documentation + "Explain to Emacs how to inspect OBJECT. + +Returns a list specifying how to render the object for inspection. + +Every element of the list must be either a string, which will be +inserted into the buffer as is, or a list of the form: + + (:value object &optional format) - Render an inspectable + object. If format is provided it must be a string and will be + rendered in place of the value, otherwise use princ-to-string. + + (:newline) - Render a \\n + + (:action label lambda &key (refresh t)) - Render LABEL (a text + string) which when clicked will call LAMBDA. If REFRESH is + non-NIL the currently inspected object will be re-inspected + after calling the lambda. +")) + +(defmethod emacs-inspect ((object t)) + "Generic method for inspecting any kind of object. + +Since we don't know how to deal with OBJECT we simply dump the +output of CL:DESCRIBE." + `("Type: " (:value ,(type-of object)) (:newline) + "Don't know how to inspect the object, dumping output of CL:DESCRIBE:" + (:newline) (:newline) + ,(with-output-to-string (desc) (describe object desc)))) + +(definterface eval-context (object) + "Return a list of bindings corresponding to OBJECT's slots." + (declare (ignore object)) + '()) + +;;; Utilities for inspector methods. +;;; + +(defun label-value-line (label value &key (newline t)) + "Create a control list which prints \"LABEL: VALUE\" in the inspector. +If NEWLINE is non-NIL a `(:newline)' is added to the result." + (list* (princ-to-string label) ": " `(:value ,value) + (if newline '((:newline)) nil))) + +(defmacro label-value-line* (&rest label-values) + ` (append ,@(loop for (label value) in label-values + collect `(label-value-line ,label ,value)))) + +(definterface describe-primitive-type (object) + "Return a string describing the primitive type of object." + (declare (ignore object)) + "N/A") + + +;;;; Multithreading +;;; +;;; The default implementations are sufficient for non-multiprocessing +;;; implementations. + +(definterface initialize-multiprocessing (continuation) + "Initialize multiprocessing, if necessary and then invoke CONTINUATION. + +Depending on the impleimentaion, this function may never return." + (funcall continuation)) + +(definterface spawn (fn &key name) + "Create a new thread to call FN.") + +(definterface thread-id (thread) + "Return an Emacs-parsable object to identify THREAD. + +Ids should be comparable with equal, i.e.: + (equal (thread-id <t1>) (thread-id <t2>)) <==> (eq <t1> <t2>)" + thread) + +(definterface find-thread (id) + "Return the thread for ID. +ID should be an id previously obtained with THREAD-ID. +Can return nil if the thread no longer exists." + (declare (ignore id)) + (current-thread)) + +(definterface thread-name (thread) + "Return the name of THREAD. +Thread names are short strings meaningful to the user. They do not +have to be unique." + (declare (ignore thread)) + "The One True Thread") + +(definterface thread-status (thread) + "Return a string describing THREAD's state." + (declare (ignore thread)) + "") + +(definterface thread-attributes (thread) + "Return a plist of implementation-dependent attributes for THREAD" + (declare (ignore thread)) + '()) + +(definterface current-thread () + "Return the currently executing thread." + 0) + +(definterface all-threads () + "Return a fresh list of all threads." + '()) + +(definterface thread-alive-p (thread) + "Test if THREAD is termintated." + (member thread (all-threads))) + +(definterface interrupt-thread (thread fn) + "Cause THREAD to execute FN.") + +(definterface kill-thread (thread) + "Terminate THREAD immediately. +Don't execute unwind-protected sections, don't raise conditions. +(Do not pass go, do not collect $200.)" + (declare (ignore thread)) + nil) + +(definterface send (thread object) + "Send OBJECT to thread THREAD." + (declare (ignore thread)) + object) + +(definterface receive (&optional timeout) + "Return the next message from current thread's mailbox." + (receive-if (constantly t) timeout)) + +(definterface receive-if (predicate &optional timeout) + "Return the first message satisfiying PREDICATE.") + +(definterface register-thread (name thread) + "Associate the thread THREAD with the symbol NAME. +The thread can then be retrieved with `find-registered'. +If THREAD is nil delete the association." + (declare (ignore name thread)) + nil) + +(definterface find-registered (name) + "Find the thread that was registered for the symbol NAME. +Return nil if the no thread was registred or if the tread is dead." + (declare (ignore name)) + nil) + +(definterface set-default-initial-binding (var form) + "Initialize special variable VAR by default with FORM. + +Some implementations initialize certain variables in each newly +created thread. This function sets the form which is used to produce +the initial value." + (set var (eval form))) + +;; List of delayed interrupts. +;; This should only have thread-local bindings, so no init form. +(defvar *pending-slime-interrupts*) + +(defun check-slime-interrupts () + "Execute pending interrupts if any. +This should be called periodically in operations which +can take a long time to complete. +Return a boolean indicating whether any interrupts was processed." + (when (and (boundp '*pending-slime-interrupts*) + *pending-slime-interrupts*) + (funcall (pop *pending-slime-interrupts*)) + t)) + +(defvar *interrupt-queued-handler* nil + "Function to call on queued interrupts. +Interrupts get queued when an interrupt occurs while interrupt +handling is disabled. + +Backends can use this function to abort slow operations.") + +(definterface wait-for-input (streams &optional timeout) + "Wait for input on a list of streams. Return those that are ready. +STREAMS is a list of streams +TIMEOUT nil, t, or real number. If TIMEOUT is t, return those streams +which are ready (or have reached end-of-file) without waiting. +If TIMEOUT is a number and no streams is ready after TIMEOUT seconds, +return nil. + +Return :interrupt if an interrupt occurs while waiting.") + + +;;;; Locks + +;; Please use locks only in swank-gray.lisp. Locks are too low-level +;; for our taste. + +(definterface make-lock (&key name) + "Make a lock for thread synchronization. +Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time +but that thread may hold it more than once." + (declare (ignore name)) + :null-lock) + +(definterface call-with-lock-held (lock function) + "Call FUNCTION with LOCK held, queueing if necessary." + (declare (ignore lock) + (type function function)) + (funcall function)) + + +;;;; Weak datastructures + +(definterface make-weak-key-hash-table (&rest args) + "Like MAKE-HASH-TABLE, but weak w.r.t. the keys." + (apply #'make-hash-table args)) + +(definterface make-weak-value-hash-table (&rest args) + "Like MAKE-HASH-TABLE, but weak w.r.t. the values." + (apply #'make-hash-table args)) + +(definterface hash-table-weakness (hashtable) + "Return nil or one of :key :value :key-or-value :key-and-value" + (declare (ignore hashtable)) + nil) + + +;;;; Character names + +(definterface character-completion-set (prefix matchp) + "Return a list of names of characters that match PREFIX." + ;; Handle the standard and semi-standard characters. + (loop for name in '("Newline" "Space" "Tab" "Page" "Rubout" + "Linefeed" "Return" "Backspace") + when (funcall matchp prefix name) + collect name)) + + +(defparameter *type-specifier-arglists* + '((and . (&rest type-specifiers)) + (array . (&optional element-type dimension-spec)) + (base-string . (&optional size)) + (bit-vector . (&optional size)) + (complex . (&optional type-specifier)) + (cons . (&optional car-typespec cdr-typespec)) + (double-float . (&optional lower-limit upper-limit)) + (eql . (object)) + (float . (&optional lower-limit upper-limit)) + (function . (&optional arg-typespec value-typespec)) + (integer . (&optional lower-limit upper-limit)) + (long-float . (&optional lower-limit upper-limit)) + (member . (&rest eql-objects)) + (mod . (n)) + (not . (type-specifier)) + (or . (&rest type-specifiers)) + (rational . (&optional lower-limit upper-limit)) + (real . (&optional lower-limit upper-limit)) + (satisfies . (predicate-symbol)) + (short-float . (&optional lower-limit upper-limit)) + (signed-byte . (&optional size)) + (simple-array . (&optional element-type dimension-spec)) + (simple-base-string . (&optional size)) + (simple-bit-vector . (&optional size)) + (simple-string . (&optional size)) + (single-float . (&optional lower-limit upper-limit)) + (simple-vector . (&optional size)) + (string . (&optional size)) + (unsigned-byte . (&optional size)) + (values . (&rest typespecs)) + (vector . (&optional element-type size)) + )) + +;;; Heap dumps + +(definterface save-image (filename &optional restart-function) + "Save a heap image to the file FILENAME. +RESTART-FUNCTION, if non-nil, should be called when the image is loaded.") + +(definterface background-save-image (filename &key restart-function + completion-function) + "Request saving a heap image to the file FILENAME. +RESTART-FUNCTION, if non-nil, should be called when the image is loaded. +COMPLETION-FUNCTION, if non-nil, should be called after saving the image.") + +(defun deinit-log-output () + ;; Can't hang on to an fd-stream from a previous session. + (setf *log-output* nil)) + + +;;;; Wrapping + +(definterface wrap (spec indicator &key before after replace) + "Intercept future calls to SPEC and surround them in callbacks. + +INDICATOR is a symbol identifying a particular wrapping, and is used +to differentiate between multiple wrappings. + +Implementations intercept calls to SPEC and call, in this order: + +* the BEFORE callback, if it's provided, with a single argument set to + the list of arguments passed to the intercepted call; + +* the original definition of SPEC recursively honouring any wrappings + previously established under different values of INDICATOR. If the + compatible function REPLACE is provided, call that instead. + +* the AFTER callback, if it's provided, with a single set to the list + of values returned by the previous call, or, if that call exited + non-locally, a single descriptive symbol, like :EXITED-NON-LOCALLY." + (declare (ignore indicator)) + (assert (symbolp spec) nil + "The default implementation for WRAP allows only simple names") + (assert (null (get spec 'slime-wrap)) nil + "The default implementation for WRAP allows a single wrapping") + (let* ((saved (symbol-function spec)) + (replacement (lambda (&rest args) + (let (retlist completed) + (unwind-protect + (progn + (when before + (funcall before args)) + (setq retlist (multiple-value-list + (apply (or replace + saved) args))) + (setq completed t) + (values-list retlist)) + (when after + (funcall after (if completed + retlist + :exited-non-locally)))))))) + (setf (get spec 'slime-wrap) (list saved replacement)) + (setf (symbol-function spec) replacement)) + spec) + +(definterface unwrap (spec indicator) + "Remove from SPEC any wrappings tagged with INDICATOR." + (if (wrapped-p spec indicator) + (setf (symbol-function spec) (first (get spec 'slime-wrap))) + (cerror "All right, so I did" + "Hmmm, ~a is not correctly wrapped, you probably redefined it" + spec)) + (setf (get spec 'slime-wrap) nil) + spec) + +(definterface wrapped-p (spec indicator) + "Returns true if SPEC is wrapped with INDICATOR." + (declare (ignore indicator)) + (and (symbolp spec) + (let ((prop-value (get spec 'slime-wrap))) + (cond ((and prop-value + (not (eq (second prop-value) + (symbol-function spec)))) + (warn "~a appears to be incorrectly wrapped" spec) + nil) + (prop-value t) + (t nil))))) diff --git a/vim/bundle/slimv/slime/swank/ccl.lisp b/vim/bundle/slimv/slime/swank/ccl.lisp new file mode 100644 index 0000000..66195c5 --- /dev/null +++ b/vim/bundle/slimv/slime/swank/ccl.lisp @@ -0,0 +1,861 @@ +;;;; -*- indent-tabs-mode: nil -*- +;;; +;;; swank-ccl.lisp --- SLIME backend for Clozure CL. +;;; +;;; Copyright (C) 2003, James Bielman <jamesjb@jamesjb.com> +;;; +;;; This program is licensed under the terms of the Lisp Lesser GNU +;;; Public License, known as the LLGPL, and distributed with Clozure CL +;;; as the file "LICENSE". The LLGPL consists of a preamble and the +;;; LGPL, which is distributed with Clozure CL as the file "LGPL". Where +;;; these conflict, the preamble takes precedence. +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(defpackage swank/ccl + (:use cl swank/backend)) + +(in-package swank/ccl) + +(eval-when (:compile-toplevel :execute :load-toplevel) + (assert (and (= ccl::*openmcl-major-version* 1) + (>= ccl::*openmcl-minor-version* 4)) + () "This file needs CCL version 1.4 or newer")) + +(defimplementation gray-package-name () + "CCL") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (multiple-value-bind (ok err) (ignore-errors (require 'xref)) + (unless ok + (warn "~a~%" err)))) + +;;; swank-mop + +(import-to-swank-mop + '( ;; classes + cl:standard-generic-function + ccl:standard-slot-definition + cl:method + cl:standard-class + ccl:eql-specializer + openmcl-mop:finalize-inheritance + openmcl-mop:compute-applicable-methods-using-classes + ;; standard-class readers + openmcl-mop:class-default-initargs + openmcl-mop:class-direct-default-initargs + openmcl-mop:class-direct-slots + openmcl-mop:class-direct-subclasses + openmcl-mop:class-direct-superclasses + openmcl-mop:class-finalized-p + cl:class-name + openmcl-mop:class-precedence-list + openmcl-mop:class-prototype + openmcl-mop:class-slots + openmcl-mop:specializer-direct-methods + ;; eql-specializer accessors + openmcl-mop:eql-specializer-object + ;; generic function readers + openmcl-mop:generic-function-argument-precedence-order + openmcl-mop:generic-function-declarations + openmcl-mop:generic-function-lambda-list + openmcl-mop:generic-function-methods + openmcl-mop:generic-function-method-class + openmcl-mop:generic-function-method-combination + openmcl-mop:generic-function-name + ;; method readers + openmcl-mop:method-generic-function + openmcl-mop:method-function + openmcl-mop:method-lambda-list + openmcl-mop:method-specializers + openmcl-mop:method-qualifiers + ;; slot readers + openmcl-mop:slot-definition-allocation + openmcl-mop:slot-definition-documentation + openmcl-mop:slot-value-using-class + openmcl-mop:slot-definition-initargs + openmcl-mop:slot-definition-initform + openmcl-mop:slot-definition-initfunction + openmcl-mop:slot-definition-name + openmcl-mop:slot-definition-type + openmcl-mop:slot-definition-readers + openmcl-mop:slot-definition-writers + openmcl-mop:slot-boundp-using-class + openmcl-mop:slot-makunbound-using-class)) + +;;; UTF8 + +(defimplementation string-to-utf8 (string) + (ccl:encode-string-to-octets string :external-format :utf-8)) + +(defimplementation utf8-to-string (octets) + (ccl:decode-string-from-octets octets :external-format :utf-8)) + +;;; TCP Server + +(defimplementation preferred-communication-style () + :spawn) + +(defimplementation create-socket (host port &key backlog) + (ccl:make-socket :connect :passive :local-port port + :local-host host :reuse-address t + :backlog (or backlog 5))) + +(defimplementation local-port (socket) + (ccl:local-port socket)) + +(defimplementation close-socket (socket) + (close socket)) + +(defimplementation accept-connection (socket &key external-format + buffering timeout) + (declare (ignore buffering timeout)) + (let ((stream-args (and external-format + `(:external-format ,external-format)))) + (ccl:accept-connection socket :wait t :stream-args stream-args))) + +(defvar *external-format-to-coding-system* + '((:iso-8859-1 + "latin-1" "latin-1-unix" "iso-latin-1-unix" + "iso-8859-1" "iso-8859-1-unix") + (:utf-8 "utf-8" "utf-8-unix"))) + +(defimplementation find-external-format (coding-system) + (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + +(defimplementation socket-fd (stream) + (ccl::ioblock-device (ccl::stream-ioblock stream t))) + +;;; Unix signals + +(defimplementation getpid () + (ccl::getpid)) + +(defimplementation lisp-implementation-type-name () + "ccl") + +;;; Arglist + +(defimplementation arglist (fname) + (multiple-value-bind (arglist binding) (let ((*break-on-signals* nil)) + (ccl:arglist fname)) + (if binding + arglist + :not-available))) + +(defimplementation function-name (function) + (ccl:function-name function)) + +(defmethod declaration-arglist ((decl-identifier (eql 'optimize))) + (let ((flags (ccl:declaration-information decl-identifier))) + (if flags + `(&any ,flags) + (call-next-method)))) + +;;; Compilation + +(defun handle-compiler-warning (condition) + "Resignal a ccl:compiler-warning as swank/backend:compiler-warning." + (signal 'compiler-condition + :original-condition condition + :message (compiler-warning-short-message condition) + :source-context nil + :severity (compiler-warning-severity condition) + :location (source-note-to-source-location + (ccl:compiler-warning-source-note condition) + (lambda () "Unknown source") + (ccl:compiler-warning-function-name condition)))) + +(defgeneric compiler-warning-severity (condition)) +(defmethod compiler-warning-severity ((c ccl:compiler-warning)) :warning) +(defmethod compiler-warning-severity ((c ccl:style-warning)) :style-warning) + +(defgeneric compiler-warning-short-message (condition)) + +;; Pretty much the same as ccl:report-compiler-warning but +;; without the source position and function name stuff. +(defmethod compiler-warning-short-message ((c ccl:compiler-warning)) + (with-output-to-string (stream) + (ccl:report-compiler-warning c stream :short t))) + +;; Needed because `ccl:report-compiler-warning' would return +;; "Nonspecific warning". +(defmethod compiler-warning-short-message ((c ccl::shadowed-typecase-clause)) + (princ-to-string c)) + +(defimplementation call-with-compilation-hooks (function) + (handler-bind ((ccl:compiler-warning 'handle-compiler-warning)) + (let ((ccl:*merge-compiler-warnings* nil)) + (funcall function)))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (with-compilation-hooks () + (compile-file input-file + :output-file output-file + :load load-p + :external-format external-format))) + +;; Use a temp file rather than in-core compilation in order to handle +;; eval-when's as compile-time. +(defimplementation swank-compile-string (string &key buffer position filename + policy) + (declare (ignore policy)) + (with-compilation-hooks () + (let ((temp-file-name (ccl:temp-pathname)) + (ccl:*save-source-locations* t)) + (unwind-protect + (progn + (with-open-file (s temp-file-name :direction :output + :if-exists :error :external-format :utf-8) + (write-string string s)) + (let ((binary-filename (compile-temp-file + temp-file-name filename buffer position))) + (delete-file binary-filename))) + (delete-file temp-file-name))))) + +(defvar *temp-file-map* (make-hash-table :test #'equal) + "A mapping from tempfile names to Emacs buffer names.") + +(defun compile-temp-file (temp-file-name buffer-file-name buffer-name offset) + (compile-file temp-file-name + :load t + :compile-file-original-truename + (or buffer-file-name + (progn + (setf (gethash temp-file-name *temp-file-map*) + buffer-name) + temp-file-name)) + :compile-file-original-buffer-offset (1- offset) + :external-format :utf-8)) + +(defimplementation save-image (filename &optional restart-function) + (ccl:save-application filename :toplevel-function restart-function)) + +;;; Cross-referencing + +(defun xref-locations (relation name &optional inverse) + (delete-duplicates + (mapcan #'find-definitions + (if inverse + (ccl::get-relation relation name :wild :exhaustive t) + (ccl::get-relation relation :wild name :exhaustive t))) + :test 'equal)) + +(defimplementation who-binds (name) + (xref-locations :binds name)) + +(defimplementation who-macroexpands (name) + (xref-locations :macro-calls name t)) + +(defimplementation who-references (name) + (remove-duplicates + (append (xref-locations :references name) + (xref-locations :sets name) + (xref-locations :binds name)) + :test 'equal)) + +(defimplementation who-sets (name) + (xref-locations :sets name)) + +(defimplementation who-calls (name) + (remove-duplicates + (append + (xref-locations :direct-calls name) + (xref-locations :indirect-calls name) + (xref-locations :macro-calls name t)) + :test 'equal)) + +(defimplementation who-specializes (class) + (when (symbolp class) + (setq class (find-class class nil))) + (when class + (delete-duplicates + (mapcar (lambda (m) + (car (find-definitions m))) + (ccl:specializer-direct-methods class)) + :test 'equal))) + +(defimplementation list-callees (name) + (remove-duplicates + (append + (xref-locations :direct-calls name t) + (xref-locations :macro-calls name nil)) + :test 'equal)) + +(defimplementation list-callers (symbol) + (delete-duplicates + (mapcan #'find-definitions (ccl:caller-functions symbol)) + :test #'equal)) + +;;; Profiling (alanr: lifted from swank-clisp) + +(defimplementation profile (fname) + (eval `(swank-monitor:monitor ,fname))) ;monitor is a macro + +(defimplementation profiled-functions () + swank-monitor:*monitored-functions*) + +(defimplementation unprofile (fname) + (eval `(swank-monitor:unmonitor ,fname))) ;unmonitor is a macro + +(defimplementation unprofile-all () + (swank-monitor:unmonitor)) + +(defimplementation profile-report () + (swank-monitor:report-monitoring)) + +(defimplementation profile-reset () + (swank-monitor:reset-all-monitoring)) + +(defimplementation profile-package (package callers-p methods) + (declare (ignore callers-p methods)) + (swank-monitor:monitor-all package)) + +;;; Debugging + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (let* (;;(*debugger-hook* nil) + ;; don't let error while printing error take us down + (ccl:*signal-printing-errors* nil)) + (funcall debugger-loop-fn))) + +;; This is called for an async interrupt and is running in a random +;; thread not selected by the user, so don't use thread-local vars +;; such as *emacs-connection*. +(defun find-repl-thread () + (let* ((*break-on-signals* nil) + (conn (swank::default-connection))) + (and (swank::multithreaded-connection-p conn) + (swank::mconn.repl-thread conn)))) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook) + (ccl:*break-hook* hook) + (ccl:*select-interactive-process-hook* 'find-repl-thread)) + (funcall fun))) + +(defimplementation install-debugger-globally (function) + (setq *debugger-hook* function) + (setq ccl:*break-hook* function) + (setq ccl:*select-interactive-process-hook* 'find-repl-thread) + ) + +(defun map-backtrace (function &optional + (start-frame-number 0) + end-frame-number) + "Call FUNCTION passing information about each stack frame + from frames START-FRAME-NUMBER to END-FRAME-NUMBER." + (let ((end-frame-number (or end-frame-number most-positive-fixnum))) + (ccl:map-call-frames function + :origin ccl:*top-error-frame* + :start-frame-number start-frame-number + :count (- end-frame-number start-frame-number)))) + +(defimplementation compute-backtrace (start-frame-number end-frame-number) + (let (result) + (map-backtrace (lambda (p context) + (push (list :frame p context) result)) + start-frame-number end-frame-number) + (nreverse result))) + +(defimplementation print-frame (frame stream) + (assert (eq (first frame) :frame)) + (destructuring-bind (p context) (rest frame) + (let ((lfun (ccl:frame-function p context))) + (format stream "(~S" (or (ccl:function-name lfun) lfun)) + (let* ((unavailable (cons nil nil)) + (args (ccl:frame-supplied-arguments p context + :unknown-marker unavailable))) + (declare (dynamic-extent unavailable)) + (if (eq args unavailable) + (format stream " #<Unknown Arguments>") + (dolist (arg args) + (if (eq arg unavailable) + (format stream " #<Unavailable>") + (format stream " ~s" arg))))) + (format stream ")")))) + +(defmacro with-frame ((p context) frame-number &body body) + `(call/frame ,frame-number (lambda (,p ,context) . ,body))) + +(defun call/frame (frame-number if-found) + (map-backtrace + (lambda (p context) + (return-from call/frame + (funcall if-found p context))) + frame-number)) + +(defimplementation frame-call (frame-number) + (with-frame (p context) frame-number + (with-output-to-string (stream) + (print-frame (list :frame p context) stream)))) + +(defimplementation frame-var-value (frame var) + (with-frame (p context) frame + (cdr (nth var (ccl:frame-named-variables p context))))) + +(defimplementation frame-locals (index) + (with-frame (p context) index + (loop for (name . value) in (ccl:frame-named-variables p context) + collect (list :name name :value value :id 0)))) + +(defimplementation frame-source-location (index) + (with-frame (p context) index + (multiple-value-bind (lfun pc) (ccl:frame-function p context) + (if pc + (pc-source-location lfun pc) + (function-source-location lfun))))) + +(defun function-name-package (name) + (etypecase name + (null nil) + (symbol (symbol-package name)) + ((cons (eql ccl::traced)) (function-name-package (second name))) + ((cons (eql setf)) (symbol-package (second name))) + ((cons (eql :internal)) (function-name-package (car (last name)))) + ((cons (and symbol (not keyword)) (cons list null)) + (symbol-package (car name))) + (standard-method (function-name-package (ccl:method-name name))))) + +(defimplementation frame-package (frame-number) + (with-frame (p context) frame-number + (let* ((lfun (ccl:frame-function p context)) + (name (ccl:function-name lfun))) + (function-name-package name)))) + +(defimplementation eval-in-frame (form index) + (with-frame (p context) index + (let ((vars (ccl:frame-named-variables p context))) + (eval `(let ,(loop for (var . val) in vars collect `(,var ',val)) + (declare (ignorable ,@(mapcar #'car vars))) + ,form))))) + +(defimplementation return-from-frame (index form) + (let ((values (multiple-value-list (eval-in-frame form index)))) + (with-frame (p context) index + (declare (ignore context)) + (ccl:apply-in-frame p #'values values)))) + +(defimplementation restart-frame (index) + (with-frame (p context) index + (ccl:apply-in-frame p + (ccl:frame-function p context) + (ccl:frame-supplied-arguments p context)))) + +(defimplementation disassemble-frame (the-frame-number) + (with-frame (p context) the-frame-number + (multiple-value-bind (lfun pc) (ccl:frame-function p context) + (format t "LFUN: ~a~%PC: ~a FP: #x~x CONTEXT: ~a~%" lfun pc p context) + (disassemble lfun)))) + +;; CCL commit r11373 | gz | 2008-11-16 16:35:28 +0100 (Sun, 16 Nov 2008) +;; contains some interesting details: +;; +;; Source location are recorded in CCL:SOURCE-NOTE's, which are objects +;; with accessors CCL:SOURCE-NOTE-FILENAME, CCL:SOURCE-NOTE-START-POS, +;; CCL:SOURCE-NOTE-END-POS and CCL:SOURCE-NOTE-TEXT. The start and end +;; positions are file positions (not character positions). The text will +;; be NIL unless text recording was on at read-time. If the original +;; file is still available, you can force missing source text to be read +;; from the file at runtime via CCL:ENSURE-SOURCE-NOTE-TEXT. +;; +;; Source-note's are associated with definitions (via record-source-file) +;; and also stored in function objects (including anonymous and nested +;; functions). The former can be retrieved via +;; CCL:FIND-DEFINITION-SOURCES, the latter via CCL:FUNCTION-SOURCE-NOTE. +;; +;; The recording behavior is controlled by the new variable +;; CCL:*SAVE-SOURCE-LOCATIONS*: +;; +;; If NIL, don't store source-notes in function objects, and store only +;; the filename for definitions (the latter only if +;; *record-source-file* is true). +;; +;; If T, store source-notes, including a copy of the original source +;; text, for function objects and definitions (the latter only if +;; *record-source-file* is true). +;; +;; If :NO-TEXT, store source-notes, but without saved text, for +;; function objects and defintions (the latter only if +;; *record-source-file* is true). This is the default. +;; +;; PC to source mapping is controlled by the new variable +;; CCL:*RECORD-PC-MAPPING*. If true (the default), functions store a +;; compressed table mapping pc offsets to corresponding source locations. +;; This can be retrieved by (CCL:FIND-SOURCE-NOTE-AT-PC function pc) +;; which returns a source-note for the source at offset pc in the +;; function. + +(defun function-source-location (function) + (source-note-to-source-location + (or (ccl:function-source-note function) + (function-name-source-note function)) + (lambda () + (format nil "Function has no source note: ~A" function)) + (ccl:function-name function))) + +(defun pc-source-location (function pc) + (source-note-to-source-location + (or (ccl:find-source-note-at-pc function pc) + (ccl:function-source-note function) + (function-name-source-note function)) + (lambda () + (format nil "No source note at PC: ~a[~d]" function pc)) + (ccl:function-name function))) + +(defun function-name-source-note (fun) + (let ((defs (ccl:find-definition-sources (ccl:function-name fun) 'function))) + (and defs + (destructuring-bind ((type . name) srcloc . srclocs) (car defs) + (declare (ignore type name srclocs)) + srcloc)))) + +(defun source-note-to-source-location (source if-nil-thunk &optional name) + (labels ((filename-to-buffer (filename) + (cond ((gethash filename *temp-file-map*) + (list :buffer (gethash filename *temp-file-map*))) + ((probe-file filename) + (list :file (ccl:native-translated-namestring + (truename filename)))) + (t (error "File ~s doesn't exist" filename))))) + (handler-case + (cond ((ccl:source-note-p source) + (let* ((full-text (ccl:source-note-text source)) + (file-name (ccl:source-note-filename source)) + (start-pos (ccl:source-note-start-pos source))) + (make-location + (when file-name (filename-to-buffer (pathname file-name))) + (when start-pos (list :position (1+ start-pos))) + (when full-text + (list :snippet (subseq full-text 0 + (min 40 (length full-text)))))))) + ((and source name) + ;; This branch is probably never used + (make-location + (filename-to-buffer source) + (list :function-name (princ-to-string + (if (functionp name) + (ccl:function-name name) + name))))) + (t `(:error ,(funcall if-nil-thunk)))) + (error (c) `(:error ,(princ-to-string c)))))) + +(defun alphatizer-definitions (name) + (let ((alpha (gethash name ccl::*nx1-alphatizers*))) + (and alpha (ccl:find-definition-sources alpha)))) + +(defun p2-definitions (name) + (let ((nx1-op (gethash name ccl::*nx1-operators*))) + (and nx1-op + (let ((dispatch (ccl::backend-p2-dispatch ccl::*target-backend*)) ) + (and (array-in-bounds-p dispatch nx1-op) + (let ((p2 (aref dispatch nx1-op))) + (and p2 + (ccl:find-definition-sources p2)))))))) + +(defimplementation find-definitions (name) + (let ((defs (append (or (ccl:find-definition-sources name) + (and (symbolp name) + (fboundp name) + (ccl:find-definition-sources + (symbol-function name)))) + (alphatizer-definitions name) + (p2-definitions name)))) + (loop for ((type . name) . sources) in defs + collect (list (definition-name type name) + (source-note-to-source-location + (find-if-not #'null sources) + (lambda () "No source-note available") + name))))) + +(defimplementation find-source-location (obj) + (let* ((defs (ccl:find-definition-sources obj)) + (best-def (or (find (ccl:name-of obj) defs :key #'cdar :test #'equal) + (car defs))) + (note (find-if-not #'null (cdr best-def)))) + (when note + (source-note-to-source-location + note + (lambda () "No source note available"))))) + +(defun definition-name (type object) + (case (ccl:definition-type-name type) + (method (ccl:name-of object)) + (t (list (ccl:definition-type-name type) (ccl:name-of object))))) + +;;; Utilities + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind &optional (sym symbol)) + (or (documentation sym kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (when (boundp symbol) + (doc 'variable))) + (maybe-push + :function (if (fboundp symbol) + (doc 'function))) + (maybe-push + :setf (let ((setf-function-name (ccl:setf-function-spec-name + `(setf ,symbol)))) + (when (fboundp setf-function-name) + (doc 'function setf-function-name)))) + (maybe-push + :type (when (ccl:type-specifier-p symbol) + (doc 'type))) + result))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + (:variable + (describe symbol)) + ((:function :generic-function) + (describe (symbol-function symbol))) + (:setf + (describe (ccl:setf-function-spec-name `(setf ,symbol)))) + (:class + (describe (find-class symbol))) + (:type + (describe (or (find-class symbol nil) symbol))))) + +;; spec ::= (:defmethod <name> {<qualifier>}* ({<specializer>}*)) +(defun parse-defmethod-spec (spec) + (values (second spec) + (subseq spec 2 (position-if #'consp spec)) + (find-if #'consp (cddr spec)))) + +(defimplementation toggle-trace (spec) + "We currently ignore just about everything." + (let ((what (ecase (first spec) + ((setf) + spec) + ((:defgeneric) + (second spec)) + ((:defmethod) + (multiple-value-bind (name qualifiers specializers) + (parse-defmethod-spec spec) + (find-method (fdefinition name) + qualifiers + specializers)))))) + (cond ((member what (trace) :test #'equal) + (ccl::%untrace what) + (format nil "~S is now untraced." what)) + (t + (ccl:trace-function what) + (format nil "~S is now traced." what))))) + +;;; Macroexpansion + +(defimplementation macroexpand-all (form &optional env) + (ccl:macroexpand-all form env)) + +;;;; Inspection + +(defun comment-type-p (type) + (or (eq type :comment) + (and (consp type) (eq (car type) :comment)))) + +(defmethod emacs-inspect ((o t)) + (let* ((inspector:*inspector-disassembly* t) + (i (inspector:make-inspector o)) + (count (inspector:compute-line-count i))) + (loop for l from 0 below count append + (multiple-value-bind (value label type) (inspector:line-n i l) + (etypecase type + ((member nil :normal) + `(,(or label "") (:value ,value) (:newline))) + ((member :colon) + (label-value-line label value)) + ((member :static) + (list (princ-to-string label) " " `(:value ,value) '(:newline))) + ((satisfies comment-type-p) + (list (princ-to-string label) '(:newline)))))))) + +(defmethod emacs-inspect :around ((o t)) + (if (or (uvector-inspector-p o) + (not (ccl:uvectorp o))) + (call-next-method) + (let ((value (call-next-method))) + (cond ((listp value) + (append value + `((:newline) + (:value ,(make-instance 'uvector-inspector :object o) + "Underlying UVECTOR")))) + (t value))))) + +(defmethod emacs-inspect ((f function)) + (append + (label-value-line "Name" (function-name f)) + `("Its argument list is: " + ,(princ-to-string (arglist f)) (:newline)) + (label-value-line "Documentation" (documentation f t)) + (when (function-lambda-expression f) + (label-value-line "Lambda Expression" + (function-lambda-expression f))) + (when (ccl:function-source-note f) + (label-value-line "Source note" + (ccl:function-source-note f))) + (when (typep f 'ccl:compiled-lexical-closure) + (append + (label-value-line "Inner function" (ccl::closure-function f)) + '("Closed over values:" (:newline)) + (loop for (name value) in (ccl::closure-closed-over-values f) + append (label-value-line (format nil " ~a" name) + value)))))) + +(defclass uvector-inspector () + ((object :initarg :object))) + +(defgeneric uvector-inspector-p (object) + (:method ((object t)) nil) + (:method ((object uvector-inspector)) t)) + +(defmethod emacs-inspect ((uv uvector-inspector)) + (with-slots (object) uv + (loop for i below (ccl:uvsize object) append + (label-value-line (princ-to-string i) (ccl:uvref object i))))) + +(defimplementation type-specifier-p (symbol) + (or (ccl:type-specifier-p symbol) + (not (eq (type-specifier-arglist symbol) :not-available)))) + +;;; Multiprocessing + +(defvar *known-processes* + (make-hash-table :size 20 :weak :key :test #'eq) + "A map from threads to mailboxes.") + +(defvar *known-processes-lock* (ccl:make-lock "*known-processes-lock*")) + +(defstruct (mailbox (:conc-name mailbox.)) + (mutex (ccl:make-lock "thread mailbox")) + (semaphore (ccl:make-semaphore)) + (queue '() :type list)) + +(defimplementation spawn (fun &key name) + (ccl:process-run-function (or name "Anonymous (Swank)") + fun)) + +(defimplementation thread-id (thread) + (ccl:process-serial-number thread)) + +(defimplementation find-thread (id) + (find id (ccl:all-processes) :key #'ccl:process-serial-number)) + +(defimplementation thread-name (thread) + (ccl:process-name thread)) + +(defimplementation thread-status (thread) + (format nil "~A" (ccl:process-whostate thread))) + +(defimplementation thread-attributes (thread) + (list :priority (ccl:process-priority thread))) + +(defimplementation make-lock (&key name) + (ccl:make-lock name)) + +(defimplementation call-with-lock-held (lock function) + (ccl:with-lock-grabbed (lock) + (funcall function))) + +(defimplementation current-thread () + ccl:*current-process*) + +(defimplementation all-threads () + (ccl:all-processes)) + +(defimplementation kill-thread (thread) + ;;(ccl:process-kill thread) ; doesn't cut it + (ccl::process-initial-form-exited thread :kill)) + +(defimplementation thread-alive-p (thread) + (not (ccl:process-exhausted-p thread))) + +(defimplementation interrupt-thread (thread function) + (ccl:process-interrupt + thread + (lambda () + (let ((ccl:*top-error-frame* (ccl::%current-exception-frame))) + (funcall function))))) + +(defun mailbox (thread) + (ccl:with-lock-grabbed (*known-processes-lock*) + (or (gethash thread *known-processes*) + (setf (gethash thread *known-processes*) (make-mailbox))))) + +(defimplementation send (thread message) + (assert message) + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) + (ccl:with-lock-grabbed (mutex) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + (ccl:signal-semaphore (mailbox.semaphore mbox))))) + +(defimplementation receive-if (test &optional timeout) + (let* ((mbox (mailbox ccl:*current-process*)) + (mutex (mailbox.mutex mbox))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (ccl:with-lock-grabbed (mutex) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) + (nconc (ldiff q tail) (cdr tail))) + (return (car tail))))) + (when (eq timeout t) (return (values nil t))) + (ccl:timed-wait-on-semaphore (mailbox.semaphore mbox) 1)))) + +(let ((alist '()) + (lock (ccl:make-lock "register-thread"))) + + (defimplementation register-thread (name thread) + (declare (type symbol name)) + (ccl:with-lock-grabbed (lock) + (etypecase thread + (null + (setf alist (delete name alist :key #'car))) + (ccl:process + (let ((probe (assoc name alist))) + (cond (probe (setf (cdr probe) thread)) + (t (setf alist (acons name thread alist)))))))) + nil) + + (defimplementation find-registered (name) + (ccl:with-lock-grabbed (lock) + (cdr (assoc name alist))))) + +(defimplementation set-default-initial-binding (var form) + (eval `(ccl::def-standard-initial-binding ,var ,form))) + +(defimplementation quit-lisp () + (ccl:quit)) + +(defimplementation set-default-directory (directory) + (let ((dir (truename (merge-pathnames directory)))) + (setf *default-pathname-defaults* (truename (merge-pathnames directory))) + (ccl:cwd dir) + (default-directory))) + +;;; Weak datastructures + +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak :key args)) + +(defimplementation make-weak-value-hash-table (&rest args) + (apply #'make-hash-table :weak :value args)) + +(defimplementation hash-table-weakness (hashtable) + (ccl:hash-table-weak-p hashtable)) + +(pushnew 'deinit-log-output ccl:*save-exit-functions*) diff --git a/vim/bundle/slimv/slime/swank/clasp.lisp b/vim/bundle/slimv/slime/swank/clasp.lisp new file mode 100644 index 0000000..3e0c4ef --- /dev/null +++ b/vim/bundle/slimv/slime/swank/clasp.lisp @@ -0,0 +1,730 @@ +;;;; -*- indent-tabs-mode: nil -*- +;;; +;;; swank-clasp.lisp --- SLIME backend for CLASP. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +;;; Administrivia + +(defpackage swank/clasp + (:use cl swank/backend)) + +(in-package swank/clasp) + + +(defmacro cslime-log (fmt &rest fmt-args) + `(format t ,fmt ,@fmt-args)) + +;; Hard dependencies. +(eval-when (:compile-toplevel :load-toplevel :execute) + (require 'sockets)) + +;; Soft dependencies. +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (probe-file "sys:profile.fas") + (require :profile) + (pushnew :profile *features*)) + (when (probe-file "sys:serve-event") + (require :serve-event) + (pushnew :serve-event *features*))) + +(declaim (optimize (debug 3))) + +;;; Swank-mop + +(eval-when (:compile-toplevel :load-toplevel :execute) + (import-swank-mop-symbols + :clos + `(:eql-specializer + :eql-specializer-object + :generic-function-declarations + :specializer-direct-methods + ,@(unless (fboundp 'clos:compute-applicable-methods-using-classes) + '(:compute-applicable-methods-using-classes))))) + +(defimplementation gray-package-name () + "GRAY") + + +;;;; TCP Server + +(defimplementation preferred-communication-style () + ;; CLASP does not provide threads yet. + ;; ECLs swank implementation says that CLOS is not thread safe and + ;; I use ECLs CLOS implementation - this is a worry for the future. + nil + ) + +(defun resolve-hostname (name) + (car (sb-bsd-sockets:host-ent-addresses + (sb-bsd-sockets:get-host-by-name name)))) + +(defimplementation create-socket (host port &key backlog) + (let ((socket (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) + (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port) + (sb-bsd-sockets:socket-listen socket (or backlog 5)) + socket)) + +(defimplementation local-port (socket) + (nth-value 1 (sb-bsd-sockets:socket-name socket))) + +(defimplementation close-socket (socket) + (sb-bsd-sockets:socket-close socket)) + +(defimplementation accept-connection (socket + &key external-format + buffering timeout) + (declare (ignore timeout)) + (sb-bsd-sockets:socket-make-stream (accept socket) + :output t + :input t + :buffering (ecase buffering + ((t) :full) + ((nil) :none) + (:line :line)) + :element-type (if external-format + 'character + '(unsigned-byte 8)) + :external-format external-format)) +(defun accept (socket) + "Like socket-accept, but retry on EAGAIN." + (loop (handler-case + (return (sb-bsd-sockets:socket-accept socket)) + (sb-bsd-sockets:interrupted-error ())))) + +(defimplementation socket-fd (socket) + (etypecase socket + (fixnum socket) + (two-way-stream (socket-fd (two-way-stream-input-stream socket))) + (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket)) + (file-stream (si:file-stream-fd socket)))) + +(defvar *external-format-to-coding-system* + '((:latin-1 + "latin-1" "latin-1-unix" "iso-latin-1-unix" + "iso-8859-1" "iso-8859-1-unix") + (:utf-8 "utf-8" "utf-8-unix"))) + +(defun external-format (coding-system) + (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*)) + (find coding-system (ext:all-encodings) :test #'string-equal))) + +(defimplementation find-external-format (coding-system) + #+unicode (external-format coding-system) + ;; Without unicode support, CLASP uses the one-byte encoding of the + ;; underlying OS, and will barf on anything except :DEFAULT. We + ;; return NIL here for known multibyte encodings, so + ;; SWANK:CREATE-SERVER will barf. + #-unicode (let ((xf (external-format coding-system))) + (if (member xf '(:utf-8)) + nil + :default))) + + +;;;; Unix Integration + +;;; If CLASP is built with thread support, it'll spawn a helper thread +;;; executing the SIGINT handler. We do not want to BREAK into that +;;; helper but into the main thread, though. This is coupled with the +;;; current choice of NIL as communication-style in so far as CLASP's +;;; main-thread is also the Slime's REPL thread. + +#+clasp-working +(defimplementation call-with-user-break-handler (real-handler function) + (let ((old-handler #'si:terminal-interrupt)) + (setf (symbol-function 'si:terminal-interrupt) + (make-interrupt-handler real-handler)) + (unwind-protect (funcall function) + (setf (symbol-function 'si:terminal-interrupt) old-handler)))) + +#+threads +(defun make-interrupt-handler (real-handler) + (let ((main-thread (find 'si:top-level (mp:all-processes) + :key #'mp:process-name))) + #'(lambda (&rest args) + (declare (ignore args)) + (mp:interrupt-process main-thread real-handler)))) + +#-threads +(defun make-interrupt-handler (real-handler) + #'(lambda (&rest args) + (declare (ignore args)) + (funcall real-handler))) + + +(defimplementation getpid () + (si:getpid)) + +(defimplementation set-default-directory (directory) + (ext:chdir (namestring directory)) ; adapts *DEFAULT-PATHNAME-DEFAULTS*. + (default-directory)) + +(defimplementation default-directory () + (namestring (ext:getcwd))) + +(defimplementation quit-lisp () + (core:quit)) + + + +;;; Instead of busy waiting with communication-style NIL, use select() +;;; on the sockets' streams. +#+serve-event +(progn + (defun poll-streams (streams timeout) + (let* ((serve-event::*descriptor-handlers* + (copy-list serve-event::*descriptor-handlers*)) + (active-fds '()) + (fd-stream-alist + (loop for s in streams + for fd = (socket-fd s) + collect (cons fd s) + do (serve-event:add-fd-handler fd :input + #'(lambda (fd) + (push fd active-fds)))))) + (serve-event:serve-event timeout) + (loop for fd in active-fds collect (cdr (assoc fd fd-stream-alist))))) + + (defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (loop + (cond ((check-slime-interrupts) (return :interrupt)) + (timeout (return (poll-streams streams 0))) + (t + (when-let (ready (poll-streams streams 0.2)) + (return ready)))))) + +) ; #+serve-event (progn ... + +#-serve-event +(defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (loop + (cond ((check-slime-interrupts) (return :interrupt)) + (timeout (return (remove-if-not #'listen streams))) + (t + (let ((ready (remove-if-not #'listen streams))) + (if ready (return ready)) + (sleep 0.1)))))) + + +;;;; Compilation + +(defvar *buffer-name* nil) +(defvar *buffer-start-position*) + +(defun signal-compiler-condition (&rest args) + (apply #'signal 'compiler-condition args)) + +#-clasp-bytecmp +(defun handle-compiler-message (condition) + ;; CLASP emits lots of noise in compiler-notes, like "Invoking + ;; external command". + (unless (typep condition 'c::compiler-note) + (signal-compiler-condition + :original-condition condition + :message (princ-to-string condition) + :severity (etypecase condition + (cmp:compiler-fatal-error :error) + (cmp:compiler-error :error) + (error :error) + (style-warning :style-warning) + (warning :warning)) + :location (condition-location condition)))) + +#-clasp-bytecmp +(defun condition-location (condition) + (let ((file (cmp:compiler-message-file condition)) + (position (cmp:compiler-message-file-position condition))) + (if (and position (not (minusp position))) + (if *buffer-name* + (make-buffer-location *buffer-name* + *buffer-start-position* + position) + (make-file-location file position)) + (make-error-location "No location found.")))) + +(defimplementation call-with-compilation-hooks (function) + (funcall function)) +#|| #-clasp-bytecmp + (handler-bind ((c:compiler-message #'handle-compiler-message)) + (funcall function))) +||# + + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (format t "Compiling file input-file = ~a output-file = ~a~%" input-file output-file) + ;; Ignore the output-file and generate our own + (let ((tmp-output-file (compile-file-pathname (si:mkstemp "TMP:clasp-swank-compile-file-")))) + (format t "Using tmp-output-file: ~a~%" tmp-output-file) + (multiple-value-bind (fasl warnings-p failure-p) + (with-compilation-hooks () + (compile-file input-file :output-file tmp-output-file + :external-format external-format)) + (values fasl warnings-p + (or failure-p + (when load-p + (not (load fasl)))))))) + +(defvar *tmpfile-map* (make-hash-table :test #'equal)) + +(defun note-buffer-tmpfile (tmp-file buffer-name) + ;; EXT:COMPILED-FUNCTION-FILE below will return a namestring. + (let ((tmp-namestring (namestring (truename tmp-file)))) + (setf (gethash tmp-namestring *tmpfile-map*) buffer-name) + tmp-namestring)) + +(defun tmpfile-to-buffer (tmp-file) + (gethash tmp-file *tmpfile-map*)) + +(defimplementation swank-compile-string (string &key buffer position filename policy) + (declare (ignore policy)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) ; for compilation hooks + (*buffer-start-position* position)) + (let ((tmp-file (si:mkstemp "TMP:clasp-swank-tmpfile-")) + (fasl-file) + (warnings-p) + (failure-p)) + (unwind-protect + (with-open-file (tmp-stream tmp-file :direction :output + :if-exists :supersede) + (write-string string tmp-stream) + (finish-output tmp-stream) + (multiple-value-setq (fasl-file warnings-p failure-p) + (let ((truename (or filename (note-buffer-tmpfile tmp-file buffer)))) + (compile-file tmp-file + :source-debug-namestring truename + :source-debug-offset (1- position))))) + (when fasl-file (load fasl-file)) + (when (probe-file tmp-file) + (delete-file tmp-file)) + (when fasl-file + (delete-file fasl-file))) + (not failure-p))))) + +;;;; Documentation + +(defimplementation arglist (name) + (multiple-value-bind (arglist foundp) + (core:function-lambda-list name) ;; Uses bc-split + (if foundp arglist :not-available))) + +(defimplementation function-name (f) + (typecase f + (generic-function (clos::generic-function-name f)) + (function (ext:compiled-function-name f)))) + +;; FIXME +(defimplementation macroexpand-all (form &optional env) + (declare (ignore env)) + (macroexpand form)) + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((frob (type boundp) + (when (funcall boundp symbol) + (let ((doc (describe-definition symbol type))) + (setf result (list* type doc result)))))) + (frob :VARIABLE #'boundp) + (frob :FUNCTION #'fboundp) + (frob :CLASS (lambda (x) (find-class x nil)))) + result)) + +(defimplementation describe-definition (name type) + (case type + (:variable (documentation name 'variable)) + (:function (documentation name 'function)) + (:class (documentation name 'class)) + (t nil))) + +(defimplementation type-specifier-p (symbol) + (or (subtypep nil symbol) + (not (eq (type-specifier-arglist symbol) :not-available)))) + + +;;; Debugging + +(eval-when (:compile-toplevel :load-toplevel :execute) + (import + '(si::*break-env* + si::*ihs-top* + si::*ihs-current* + si::*ihs-base* +#+frs si::*frs-base* +#+frs si::*frs-top* + si::*tpl-commands* + si::*tpl-level* +#+frs si::frs-top + si::ihs-top + si::ihs-fun + si::ihs-env +#+frs si::sch-frs-base + si::set-break-env + si::set-current-ihs + si::tpl-commands))) + +(defun make-invoke-debugger-hook (hook) + (when hook + #'(lambda (condition old-hook) + ;; Regard *debugger-hook* if set by user. + (if *debugger-hook* + nil ; decline, *DEBUGGER-HOOK* will be tried next. + (funcall hook condition old-hook))))) + +(defimplementation install-debugger-globally (function) + (setq *debugger-hook* function) + (setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function)) + ) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook) + (ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))) + (funcall fun)) + ) + +(defvar *backtrace* '()) + +;;; Commented out; it's not clear this is a good way of doing it. In +;;; particular because it makes errors stemming from this file harder +;;; to debug, and given the "young" age of CLASP's swank backend, that's +;;; a bad idea. + +;; (defun in-swank-package-p (x) +;; (and +;; (symbolp x) +;; (member (symbol-package x) +;; (list #.(find-package :swank) +;; #.(find-package :swank/backend) +;; #.(ignore-errors (find-package :swank-mop)) +;; #.(ignore-errors (find-package :swank-loader)))) +;; t)) + +;; (defun is-swank-source-p (name) +;; (setf name (pathname name)) +;; (pathname-match-p +;; name +;; (make-pathname :defaults swank-loader::*source-directory* +;; :name (pathname-name name) +;; :type (pathname-type name) +;; :version (pathname-version name)))) + +;; (defun is-ignorable-fun-p (x) +;; (or +;; (in-swank-package-p (frame-name x)) +;; (multiple-value-bind (file position) +;; (ignore-errors (si::bc-file (car x))) +;; (declare (ignore position)) +;; (if file (is-swank-source-p file))))) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (declare (type function debugger-loop-fn)) + (let* ((*ihs-top* (or #+#.(swank/backend:with-symbol '*stack-top-hint* 'core) + core:*stack-top-hint* + (ihs-top))) + (*ihs-current* *ihs-top*) +#+frs (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top)))) +#+frs (*frs-top* (frs-top)) + (*tpl-level* (1+ *tpl-level*)) + (*backtrace* (loop for ihs from 0 below *ihs-top* + collect (list (si::ihs-fun ihs) + (si::ihs-env ihs) + ihs)))) + (declare (special *ihs-current*)) +#+frs (loop for f from *frs-base* until *frs-top* + do (let ((i (- (si::frs-ihs f) *ihs-base* 1))) + (when (plusp i) + (let* ((x (elt *backtrace* i)) + (name (si::frs-tag f))) + (unless (si::fixnump name) + (push name (third x))))))) + (setf *backtrace* (nreverse *backtrace*)) + (set-break-env) + (set-current-ihs) + (let ((*ihs-base* *ihs-top*)) + (funcall debugger-loop-fn)))) + +(defimplementation compute-backtrace (start end) + (subseq *backtrace* start + (and (numberp end) + (min end (length *backtrace*))))) + +(defun frame-name (frame) + (let ((x (first frame))) + (if (symbolp x) + x + (function-name x)))) + +(defun frame-function (frame-number) + (let ((x (first (elt *backtrace* frame-number)))) + (etypecase x + (symbol + (and (fboundp x) + (fdefinition x))) + (function + x)))) + +(defimplementation print-frame (frame stream) + (format stream "(~s~{ ~s~})" (function-name (first frame)) + #+#.(swank/backend:with-symbol 'ihs-arguments 'core) + (coerce (core:ihs-arguments (third frame)) 'list) + #-#.(swank/backend:with-symbol 'ihs-arguments 'core) + nil)) + +(defimplementation frame-source-location (frame-number) + (source-location (frame-function frame-number))) + +#+clasp-working +(defimplementation frame-catch-tags (frame-number) + (third (elt *backtrace* frame-number))) + +(defun ihs-frame-id (frame-number) + (- (core:ihs-top) frame-number)) + +(defimplementation frame-locals (frame-number) + (let* ((frame (elt *backtrace* frame-number)) + (env (second frame)) + (locals (loop for x = env then (core:get-parent-environment x) + while x + nconc (loop for name across (core:environment-debug-names x) + for value across (core:environment-debug-values x) + collect (list :name name :id 0 :value value))))) + (nconc + (loop for arg across (core:ihs-arguments (third frame)) + for i from 0 + collect (list :name (intern (format nil "ARG~d" i) #.*package*) + :id 0 + :value arg)) + locals))) + +(defimplementation frame-var-value (frame-number var-number) + (let* ((frame (elt *backtrace* frame-number)) + (env (second frame)) + (args (core:ihs-arguments (third frame)))) + (if (< var-number (length args)) + (svref args var-number) + (elt (frame-locals frame-number) var-number)))) + +#+clasp-working +(defimplementation disassemble-frame (frame-number) + (let ((fun (frame-function frame-number))) + (disassemble fun))) + +(defimplementation eval-in-frame (form frame-number) + (let ((env (second (elt *backtrace* frame-number)))) + (core:compile-form-and-eval-with-env form env))) + +#+clasp-working +(defimplementation gdb-initial-commands () + ;; These signals are used by the GC. + #+linux '("handle SIGPWR noprint nostop" + "handle SIGXCPU noprint nostop")) + +#+clasp-working +(defimplementation command-line-args () + (loop for n from 0 below (si:argc) collect (si:argv n))) + + +;;;; Inspector + +;;; FIXME: Would be nice if it was possible to inspect objects +;;; implemented in C. + + +;;;; Definitions + +(defun make-file-location (file file-position) + ;; File positions in CL start at 0, but Emacs' buffer positions + ;; start at 1. We specify (:ALIGN T) because the positions comming + ;; from CLASP point at right after the toplevel form appearing before + ;; the actual target toplevel form; (:ALIGN T) will DTRT in that case. + (make-location `(:file ,(namestring (translate-logical-pathname file))) + `(:position ,(1+ file-position)) + `(:align t))) + +(defun make-buffer-location (buffer-name start-position &optional (offset 0)) + (make-location `(:buffer ,buffer-name) + `(:offset ,start-position ,offset) + `(:align t))) + +(defun translate-location (location) + (make-location (list :file (namestring (ext:source-location-pathname location))) + (list :position (ext:source-location-offset location)) + '(:align t))) + +(defimplementation find-definitions (name) + (loop for kind in ext:*source-location-kinds* + for locations = (ext:source-location name kind) + when locations + nconc (loop for location in locations + collect (list kind (translate-location location))))) + +(defun source-location (object) + (let ((location (ext:source-location object t))) + (when location + (translate-location (car location))))) + +(defimplementation find-source-location (object) + (or (source-location object) + (make-error-location "Source definition of ~S not found." object))) + + +;;;; Profiling + +#+profile +(progn + +(defimplementation profile (fname) + (when fname (eval `(profile:profile ,fname)))) + +(defimplementation unprofile (fname) + (when fname (eval `(profile:unprofile ,fname)))) + +(defimplementation unprofile-all () + (profile:unprofile-all) + "All functions unprofiled.") + +(defimplementation profile-report () + (profile:report)) + +(defimplementation profile-reset () + (profile:reset) + "Reset profiling counters.") + +(defimplementation profiled-functions () + (profile:profile)) + +(defimplementation profile-package (package callers methods) + (declare (ignore callers methods)) + (eval `(profile:profile ,(package-name (find-package package))))) +) ; #+profile (progn ... + + +;;;; Threads + +#+threads +(progn + (defvar *thread-id-counter* 0) + + (defparameter *thread-id-map* (make-hash-table)) + + (defvar *thread-id-map-lock* + (mp:make-lock :name "thread id map lock")) + + (defimplementation spawn (fn &key name) + (mp:process-run-function name fn)) + + (defimplementation thread-id (target-thread) + (block thread-id + (mp:with-lock (*thread-id-map-lock*) + ;; Does TARGET-THREAD have an id already? + (maphash (lambda (id thread-pointer) + (let ((thread (si:weak-pointer-value thread-pointer))) + (cond ((not thread) + (remhash id *thread-id-map*)) + ((eq thread target-thread) + (return-from thread-id id))))) + *thread-id-map*) + ;; TARGET-THREAD not found in *THREAD-ID-MAP* + (let ((id (incf *thread-id-counter*)) + (thread-pointer (si:make-weak-pointer target-thread))) + (setf (gethash id *thread-id-map*) thread-pointer) + id)))) + + (defimplementation find-thread (id) + (mp:with-lock (*thread-id-map-lock*) + (let* ((thread-ptr (gethash id *thread-id-map*)) + (thread (and thread-ptr (si:weak-pointer-value thread-ptr)))) + (unless thread + (remhash id *thread-id-map*)) + thread))) + + (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 :recursive t)) + + (defimplementation call-with-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")) + (defvar *mailboxes* (list)) + (declaim (type list *mailboxes*)) + + (defstruct (mailbox (:conc-name mailbox.)) + thread + (mutex (mp:make-lock)) + (cvar (mp:make-condition-variable)) + (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:with-lock (mutex) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + (mp:condition-variable-broadcast (mailbox.cvar mbox))))) + + (defimplementation receive-if (test &optional timeout) + (let* ((mbox (mailbox (current-thread))) + (mutex (mailbox.mutex mbox))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (mp:with-lock (mutex) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail)))) + (when (eq timeout t) (return (values nil t))) + (mp:condition-variable-timedwait (mailbox.cvar mbox) + mutex + 0.2))))) + + ) ; #+threads (progn ... + + +(defmethod emacs-inspect ((object core:cxx-object)) + (let ((encoded (core:encode object))) + (loop for (key . value) in encoded + append (list (string key) ": " (list :value value) (list :newline))))) diff --git a/vim/bundle/slimv/slime/swank/clisp.lisp b/vim/bundle/slimv/slime/swank/clisp.lisp new file mode 100644 index 0000000..27ae688 --- /dev/null +++ b/vim/bundle/slimv/slime/swank/clisp.lisp @@ -0,0 +1,930 @@ +;;;; -*- indent-tabs-mode: nil -*- + +;;;; SWANK support for CLISP. + +;;;; Copyright (C) 2003, 2004 W. Jenkner, V. Sedach + +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU General Public License as +;;;; published by the Free Software Foundation; either version 2 of +;;;; the License, or (at your option) any later version. + +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. + +;;;; You should have received a copy of the GNU General Public +;;;; License along with this program; if not, write to the Free +;;;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +;;;; MA 02111-1307, USA. + +;;; This is work in progress, but it's already usable. Many things +;;; are adapted from other swank-*.lisp, in particular from +;;; swank-allegro (I don't use allegro at all, but it's the shortest +;;; one and I found Helmut Eller's code there enlightening). + +;;; This code will work better with recent versions of CLISP (say, the +;;; last release or CVS HEAD) while it may not work at all with older +;;; versions. It is reasonable to expect it to work on platforms with +;;; a "SOCKET" package, in particular on GNU/Linux or Unix-like +;;; systems, but also on Win32. This backend uses the portable xref +;;; from the CMU AI repository and metering.lisp from CLOCC [1], which +;;; are conveniently included in SLIME. + +;;; [1] http://cvs.sourceforge.net/viewcvs.py/clocc/clocc/src/tools/metering/ + +(defpackage swank/clisp + (:use cl swank/backend)) + +(in-package swank/clisp) + +(eval-when (:compile-toplevel) + (unless (string< "2.44" (lisp-implementation-version)) + (error "Need at least CLISP version 2.44"))) + +(defimplementation gray-package-name () + "GRAY") + +;;;; if this lisp has the complete CLOS then we use it, otherwise we +;;;; build up a "fake" swank-mop and then override the methods in the +;;;; inspector. + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar *have-mop* + (and (find-package :clos) + (eql :external + (nth-value 1 (find-symbol (string ':standard-slot-definition) + :clos)))) + "True in those CLISP images which have a complete MOP implementation.")) + +#+#.(cl:if swank/clisp::*have-mop* '(cl:and) '(cl:or)) +(progn + (import-swank-mop-symbols :clos '(:slot-definition-documentation)) + + (defun swank-mop:slot-definition-documentation (slot) + (clos::slot-definition-documentation slot))) + +#-#.(cl:if swank/clisp::*have-mop* '(and) '(or)) +(defclass swank-mop:standard-slot-definition () + () + (:documentation + "Dummy class created so that swank.lisp will compile and load.")) + +(let ((getpid (or (find-symbol "PROCESS-ID" :system) + ;; old name prior to 2005-03-01, clisp <= 2.33.2 + (find-symbol "PROGRAM-ID" :system) + #+win32 ; integrated into the above since 2005-02-24 + (and (find-package :win32) ; optional modules/win32 + (find-symbol "GetCurrentProcessId" :win32))))) + (defimplementation getpid () ; a required interface + (cond + (getpid (funcall getpid)) + #+win32 ((ext:getenv "PID")) ; where does that come from? + (t -1)))) + +(defimplementation call-with-user-break-handler (handler function) + (handler-bind ((system::simple-interrupt-condition + (lambda (c) + (declare (ignore c)) + (funcall handler) + (when (find-restart 'socket-status) + (invoke-restart (find-restart 'socket-status))) + (continue)))) + (funcall function))) + +(defimplementation lisp-implementation-type-name () + "clisp") + +(defimplementation set-default-directory (directory) + (setf (ext:default-directory) directory) + (namestring (setf *default-pathname-defaults* (ext:default-directory)))) + +(defimplementation filename-to-pathname (string) + (cond ((member :cygwin *features*) + (parse-cygwin-filename string)) + (t (parse-namestring string)))) + +(defun parse-cygwin-filename (string) + (multiple-value-bind (match _ drive absolute) + (regexp:match "^(([a-zA-Z\\]+):)?([\\/])?" string :extended t) + (declare (ignore _)) + (assert (and match (if drive absolute t)) () + "Invalid filename syntax: ~a" string) + (let* ((sans-prefix (subseq string (regexp:match-end match))) + (path (remove "" (regexp:regexp-split "[\\/]" sans-prefix))) + (path (loop for name in path collect + (cond ((equal name "..") ':back) + (t name)))) + (directoryp (or (equal string "") + (find (aref string (1- (length string))) "\\/")))) + (multiple-value-bind (file type) + (cond ((and (not directoryp) (last path)) + (let* ((file (car (last path))) + (pos (position #\. file :from-end t))) + (cond ((and pos (> pos 0)) + (values (subseq file 0 pos) + (subseq file (1+ pos)))) + (t file))))) + (make-pathname :host nil + :device nil + :directory (cons + (if absolute :absolute :relative) + (let ((path (if directoryp + path + (butlast path)))) + (if drive + (cons + (regexp:match-string string drive) + path) + path))) + :name file + :type type))))) + +;;;; UTF + +(defimplementation string-to-utf8 (string) + (let ((enc (load-time-value + (ext:make-encoding :charset "utf-8" :line-terminator :unix) + t))) + (ext:convert-string-to-bytes string enc))) + +(defimplementation utf8-to-string (octets) + (let ((enc (load-time-value + (ext:make-encoding :charset "utf-8" :line-terminator :unix) + t))) + (ext:convert-string-from-bytes octets enc))) + +;;;; TCP Server + +(defimplementation create-socket (host port &key backlog) + (socket:socket-server port :interface host :backlog (or backlog 5))) + +(defimplementation local-port (socket) + (socket:socket-server-port socket)) + +(defimplementation close-socket (socket) + (socket:socket-server-close socket)) + +(defimplementation accept-connection (socket + &key external-format buffering timeout) + (declare (ignore buffering timeout)) + (socket:socket-accept socket + :buffered buffering ;; XXX may not work if t + :element-type (if external-format + 'character + '(unsigned-byte 8)) + :external-format (or external-format :default))) + +#-win32 +(defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (let ((streams (mapcar (lambda (s) (list* s :input nil)) streams))) + (loop + (cond ((check-slime-interrupts) (return :interrupt)) + (timeout + (socket:socket-status streams 0 0) + (return (loop for (s nil . x) in streams + if x collect s))) + (t + (with-simple-restart (socket-status "Return from socket-status.") + (socket:socket-status streams 0 500000)) + (let ((ready (loop for (s nil . x) in streams + if x collect s))) + (when ready (return ready)))))))) + +#+win32 +(defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (loop + (cond ((check-slime-interrupts) (return :interrupt)) + (t + (let ((ready (remove-if-not #'input-available-p streams))) + (when ready (return ready))) + (when timeout (return nil)) + (sleep 0.1))))) + +#+win32 +;; Some facts to remember (for the next time we need to debug this): +;; - interactive-sream-p returns t for socket-streams +;; - listen returns nil for socket-streams +;; - (type-of <socket-stream>) is 'stream +;; - (type-of *terminal-io*) is 'two-way-stream +;; - stream-element-type on our sockets is usually (UNSIGNED-BYTE 8) +;; - calling socket:socket-status on non sockets signals an error, +;; but seems to mess up something internally. +;; - calling read-char-no-hang on sockets does not signal an error, +;; but seems to mess up something internally. +(defun input-available-p (stream) + (case (stream-element-type stream) + (character + (let ((c (read-char-no-hang stream nil nil))) + (cond ((not c) + nil) + (t + (unread-char c stream) + t)))) + (t + (eq (socket:socket-status (cons stream :input) 0 0) + :input)))) + +;;;; Coding systems + +(defvar *external-format-to-coding-system* + '(((:charset "iso-8859-1" :line-terminator :unix) + "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix") + ((:charset "iso-8859-1") + "latin-1" "iso-latin-1" "iso-8859-1") + ((:charset "utf-8") "utf-8") + ((:charset "utf-8" :line-terminator :unix) "utf-8-unix") + ((:charset "euc-jp") "euc-jp") + ((:charset "euc-jp" :line-terminator :unix) "euc-jp-unix") + ((:charset "us-ascii") "us-ascii") + ((:charset "us-ascii" :line-terminator :unix) "us-ascii-unix"))) + +(defimplementation find-external-format (coding-system) + (let ((args (car (rassoc-if (lambda (x) + (member coding-system x :test #'equal)) + *external-format-to-coding-system*)))) + (and args (apply #'ext:make-encoding args)))) + + +;;;; Swank functions + +(defimplementation arglist (fname) + (block nil + (or (ignore-errors + (let ((exp (function-lambda-expression fname))) + (and exp (return (second exp))))) + (ignore-errors + (return (ext:arglist fname))) + :not-available))) + +(defimplementation macroexpand-all (form &optional env) + (declare (ignore env)) + (ext:expand-form form)) + +(defimplementation collect-macro-forms (form &optional env) + ;; Currently detects only normal macros, not compiler macros. + (declare (ignore env)) + (with-collected-macro-forms (macro-forms) + (handler-bind ((warning #'muffle-warning)) + (ignore-errors + (compile nil `(lambda () ,form)))) + (values macro-forms nil))) + +(defimplementation describe-symbol-for-emacs (symbol) + "Return a plist describing SYMBOL. +Return NIL if the symbol is unbound." + (let ((result ())) + (flet ((doc (kind) + (or (documentation symbol kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push :variable (when (boundp symbol) (doc 'variable))) + (when (fboundp symbol) + (maybe-push + ;; Report WHEN etc. as macros, even though they may be + ;; implemented as special operators. + (if (macro-function symbol) :macro + (typecase (fdefinition symbol) + (generic-function :generic-function) + (function :function) + ;; (type-of 'progn) -> ext:special-operator + (t :special-operator))) + (doc 'function))) + (when (or (get symbol 'system::setf-function) ; e.g. #'(setf elt) + (get symbol 'system::setf-expander)); defsetf + (maybe-push :setf (doc 'setf))) + (when (or (get symbol 'system::type-symbol); cf. clisp/src/describe.lisp + (get symbol 'system::defstruct-description) + (get symbol 'system::deftype-expander)) + (maybe-push :type (doc 'type))) ; even for 'structure + (when (find-class symbol nil) + (maybe-push :class (doc 'type))) + ;; Let this code work compiled in images without FFI + (let ((types (load-time-value + (and (find-package "FFI") + (symbol-value + (find-symbol "*C-TYPE-TABLE*" "FFI")))))) + ;; Use ffi::*c-type-table* so as not to suffer the overhead of + ;; (ignore-errors (ffi:parse-c-type symbol)) for 99.9% of symbols + ;; which are not FFI type names. + (when (and types (nth-value 1 (gethash symbol types))) + ;; Maybe use (case (head (ffi:deparse-c-type))) + ;; to distinguish struct and union types? + (maybe-push :alien-type :not-documented))) + result))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + (:variable (describe symbol)) + (:macro (describe (macro-function symbol))) + (:function (describe (symbol-function symbol))) + (:class (describe (find-class symbol))))) + +(defimplementation type-specifier-p (symbol) + (or (ignore-errors + (subtypep nil symbol)) + (not (eq (type-specifier-arglist symbol) :not-available)))) + +(defun fspec-pathname (spec) + (let ((path spec) + type + lines) + (when (consp path) + (psetq type (car path) + path (cadr path) + lines (cddr path))) + (when (and path + (member (pathname-type path) + custom:*compiled-file-types* :test #'equal)) + (setq path + (loop for suffix in custom:*source-file-types* + thereis (probe-file (make-pathname :defaults path + :type suffix))))) + (values path type lines))) + +(defun fspec-location (name fspec) + (multiple-value-bind (file type lines) + (fspec-pathname fspec) + (list (if type (list name type) name) + (cond (file + (multiple-value-bind (truename c) + (ignore-errors (truename file)) + (cond (truename + (make-location + (list :file (namestring truename)) + (if (consp lines) + (list* :line lines) + (list :function-name (string name))) + (when (consp type) + (list :snippet (format nil "~A" type))))) + (t (list :error (princ-to-string c)))))) + (t (list :error + (format nil "No source information available for: ~S" + fspec))))))) + +(defimplementation find-definitions (name) + (mapcar #'(lambda (e) (fspec-location name e)) + (documentation name 'sys::file))) + +(defun trim-whitespace (string) + (string-trim #(#\newline #\space #\tab) string)) + +(defvar *sldb-backtrace*) + +(defun sldb-backtrace () + "Return a list ((ADDRESS . DESCRIPTION) ...) of frames." + (let* ((modes '((:all-stack-elements 1) + (:all-frames 2) + (:only-lexical-frames 3) + (:only-eval-and-apply-frames 4) + (:only-apply-frames 5))) + (mode (cadr (assoc :all-stack-elements modes)))) + (do ((frames '()) + (last nil frame) + (frame (sys::the-frame) + (sys::frame-up 1 frame mode))) + ((eq frame last) (nreverse frames)) + (unless (boring-frame-p frame) + (push frame frames))))) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (let* (;;(sys::*break-count* (1+ sys::*break-count*)) + ;;(sys::*driver* debugger-loop-fn) + ;;(sys::*fasoutput-stream* nil) + (*sldb-backtrace* + (let* ((f (sys::the-frame)) + (bt (sldb-backtrace)) + (rest (member f bt))) + (if rest (nthcdr 8 rest) bt)))) + (funcall debugger-loop-fn))) + +(defun nth-frame (index) + (nth index *sldb-backtrace*)) + +(defun boring-frame-p (frame) + (member (frame-type frame) '(stack-value bind-var bind-env + compiled-tagbody compiled-block))) + +(defun frame-to-string (frame) + (with-output-to-string (s) + (sys::describe-frame s frame))) + +(defun frame-type (frame) + ;; FIXME: should bind *print-length* etc. to small values. + (frame-string-type (frame-to-string frame))) + +;; FIXME: they changed the layout in 2.44 and not all patterns have +;; been updated. +(defvar *frame-prefixes* + '(("\\[[0-9]\\+\\] frame binding variables" bind-var) + ("<1> #<compiled-function" compiled-fun) + ("<1> #<system-function" sys-fun) + ("<1> #<special-operator" special-op) + ("EVAL frame" eval) + ("APPLY frame" apply) + ("\\[[0-9]\\+\\] compiled tagbody frame" compiled-tagbody) + ("\\[[0-9]\\+\\] compiled block frame" compiled-block) + ("block frame" block) + ("nested block frame" block) + ("tagbody frame" tagbody) + ("nested tagbody frame" tagbody) + ("catch frame" catch) + ("handler frame" handler) + ("unwind-protect frame" unwind-protect) + ("driver frame" driver) + ("\\[[0-9]\\+\\] frame binding environments" bind-env) + ("CALLBACK frame" callback) + ("- " stack-value) + ("<1> " fun) + ("<2> " 2nd-frame) + )) + +(defun frame-string-type (string) + (cadr (assoc-if (lambda (pattern) (is-prefix-p pattern string)) + *frame-prefixes*))) + +(defimplementation compute-backtrace (start end) + (let* ((bt *sldb-backtrace*) + (len (length bt))) + (loop for f in (subseq bt start (min (or end len) len)) + collect f))) + +(defimplementation print-frame (frame stream) + (let* ((str (frame-to-string frame))) + (write-string (extract-frame-line str) + stream))) + +(defun extract-frame-line (frame-string) + (let ((s frame-string)) + (trim-whitespace + (case (frame-string-type s) + ((eval special-op) + (string-match "EVAL frame .*for form \\(.*\\)" s 1)) + (apply + (string-match "APPLY frame for call \\(.*\\)" s 1)) + ((compiled-fun sys-fun fun) + (extract-function-name s)) + (t s))))) + +(defun extract-function-name (string) + (let ((1st (car (split-frame-string string)))) + (or (string-match (format nil "^<1>[ ~%]*#<[-A-Za-z]* \\(.*\\)>") + 1st + 1) + (string-match (format nil "^<1>[ ~%]*\\(.*\\)") 1st 1) + 1st))) + +(defun split-frame-string (string) + (let ((rx (format nil "~%\\(~{~A~^\\|~}\\)" + (mapcar #'car *frame-prefixes*)))) + (loop for pos = 0 then (1+ (regexp:match-start match)) + for match = (regexp:match rx string :start pos) + if match collect (subseq string pos (regexp:match-start match)) + else collect (subseq string pos) + while match))) + +(defun string-match (pattern string n) + (let* ((match (nth-value n (regexp:match pattern string)))) + (if match (regexp:match-string string match)))) + +(defimplementation eval-in-frame (form frame-number) + (sys::eval-at (nth-frame frame-number) form)) + +(defimplementation frame-locals (frame-number) + (let ((frame (nth-frame frame-number))) + (loop for i below (%frame-count-vars frame) + collect (list :name (%frame-var-name frame i) + :value (%frame-var-value frame i) + :id 0)))) + +(defimplementation frame-var-value (frame var) + (%frame-var-value (nth-frame frame) var)) + +;;; Interpreter-Variablen-Environment has the shape +;;; NIL or #(v1 val1 ... vn valn NEXT-ENV). + +(defun %frame-count-vars (frame) + (cond ((sys::eval-frame-p frame) + (do ((venv (frame-venv frame) (next-venv venv)) + (count 0 (+ count (/ (1- (length venv)) 2)))) + ((not venv) count))) + ((member (frame-type frame) '(compiled-fun sys-fun fun special-op)) + (length (%parse-stack-values frame))) + (t 0))) + +(defun %frame-var-name (frame i) + (cond ((sys::eval-frame-p frame) + (nth-value 0 (venv-ref (frame-venv frame) i))) + (t (format nil "~D" i)))) + +(defun %frame-var-value (frame i) + (cond ((sys::eval-frame-p frame) + (let ((name (venv-ref (frame-venv frame) i))) + (multiple-value-bind (v c) (ignore-errors (sys::eval-at frame name)) + (if c + (format-sldb-condition c) + v)))) + ((member (frame-type frame) '(compiled-fun sys-fun fun special-op)) + (let ((str (nth i (%parse-stack-values frame)))) + (trim-whitespace (subseq str 2)))) + (t (break "Not implemented")))) + +(defun frame-venv (frame) + (let ((env (sys::eval-at frame '(sys::the-environment)))) + (svref env 0))) + +(defun next-venv (venv) (svref venv (1- (length venv)))) + +(defun venv-ref (env i) + "Reference the Ith binding in ENV. +Return two values: NAME and VALUE" + (let ((idx (* i 2))) + (if (< idx (1- (length env))) + (values (svref env idx) (svref env (1+ idx))) + (venv-ref (next-venv env) (- i (/ (1- (length env)) 2)))))) + +(defun %parse-stack-values (frame) + (labels ((next (fp) (sys::frame-down 1 fp 1)) + (parse (fp accu) + (let ((str (frame-to-string fp))) + (cond ((is-prefix-p "- " str) + (parse (next fp) (cons str accu))) + ((is-prefix-p "<1> " str) + ;;(when (eq (frame-type frame) 'compiled-fun) + ;; (pop accu)) + (dolist (str (cdr (split-frame-string str))) + (when (is-prefix-p "- " str) + (push str accu))) + (nreverse accu)) + (t (parse (next fp) accu)))))) + (parse (next frame) '()))) + +(defun is-prefix-p (regexp string) + (if (regexp:match (concatenate 'string "^" regexp) string) t)) + +(defimplementation return-from-frame (index form) + (sys::return-from-eval-frame (nth-frame index) form)) + +(defimplementation restart-frame (index) + (sys::redo-eval-frame (nth-frame index))) + +(defimplementation frame-source-location (index) + `(:error + ,(format nil "frame-source-location not implemented. (frame: ~A)" + (nth-frame index)))) + +;;;; Profiling + +(defimplementation profile (fname) + (eval `(swank-monitor:monitor ,fname))) ;monitor is a macro + +(defimplementation profiled-functions () + swank-monitor:*monitored-functions*) + +(defimplementation unprofile (fname) + (eval `(swank-monitor:unmonitor ,fname))) ;unmonitor is a macro + +(defimplementation unprofile-all () + (swank-monitor:unmonitor)) + +(defimplementation profile-report () + (swank-monitor:report-monitoring)) + +(defimplementation profile-reset () + (swank-monitor:reset-all-monitoring)) + +(defimplementation profile-package (package callers-p methods) + (declare (ignore callers-p methods)) + (swank-monitor:monitor-all package)) + +;;;; Handle compiler conditions (find out location of error etc.) + +(defmacro compile-file-frobbing-notes ((&rest args) &body body) + "Pass ARGS to COMPILE-FILE, send the compiler notes to +*STANDARD-INPUT* and frob them in BODY." + `(let ((*error-output* (make-string-output-stream)) + (*compile-verbose* t)) + (multiple-value-prog1 + (compile-file ,@args) + (handler-case + (with-input-from-string + (*standard-input* (get-output-stream-string *error-output*)) + ,@body) + (sys::simple-end-of-file () nil))))) + +(defvar *orig-c-warn* (symbol-function 'system::c-warn)) +(defvar *orig-c-style-warn* (symbol-function 'system::c-style-warn)) +(defvar *orig-c-error* (symbol-function 'system::c-error)) +(defvar *orig-c-report-problems* (symbol-function 'system::c-report-problems)) + +(defmacro dynamic-flet (names-functions &body body) + "(dynamic-flet ((NAME FUNCTION) ...) BODY ...) +Execute BODY with NAME's function slot set to FUNCTION." + `(ext:letf* ,(loop for (name function) in names-functions + collect `((symbol-function ',name) ,function)) + ,@body)) + +(defvar *buffer-name* nil) +(defvar *buffer-offset*) + +(defun compiler-note-location () + "Return the current compiler location." + (let ((lineno1 sys::*compile-file-lineno1*) + (lineno2 sys::*compile-file-lineno2*) + (file sys::*compile-file-truename*)) + (cond ((and file lineno1 lineno2) + (make-location (list ':file (namestring file)) + (list ':line lineno1))) + (*buffer-name* + (make-location (list ':buffer *buffer-name*) + (list ':offset *buffer-offset* 0))) + (t + (list :error "No error location available"))))) + +(defun signal-compiler-warning (cstring args severity orig-fn) + (signal 'compiler-condition + :severity severity + :message (apply #'format nil cstring args) + :location (compiler-note-location)) + (apply orig-fn cstring args)) + +(defun c-warn (cstring &rest args) + (signal-compiler-warning cstring args :warning *orig-c-warn*)) + +(defun c-style-warn (cstring &rest args) + (dynamic-flet ((sys::c-warn *orig-c-warn*)) + (signal-compiler-warning cstring args :style-warning *orig-c-style-warn*))) + +(defun c-error (&rest args) + (signal 'compiler-condition + :severity :error + :message (apply #'format nil + (if (= (length args) 3) + (cdr args) + args)) + :location (compiler-note-location)) + (apply *orig-c-error* args)) + +(defimplementation call-with-compilation-hooks (function) + (handler-bind ((warning #'handle-notification-condition)) + (dynamic-flet ((system::c-warn #'c-warn) + (system::c-style-warn #'c-style-warn) + (system::c-error #'c-error)) + (funcall function)))) + +(defun handle-notification-condition (condition) + "Handle a condition caused by a compiler warning." + (signal 'compiler-condition + :original-condition condition + :severity :warning + :message (princ-to-string condition) + :location (compiler-note-location))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (with-compilation-hooks () + (with-compilation-unit () + (multiple-value-bind (fasl-file warningsp failurep) + (compile-file input-file + :output-file output-file + :external-format external-format) + (values fasl-file warningsp + (or failurep + (and load-p + (not (load fasl-file))))))))) + +(defimplementation swank-compile-string (string &key buffer position filename + policy) + (declare (ignore filename policy)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-offset* position)) + (funcall (compile nil (read-from-string + (format nil "(~S () ~A)" 'lambda string)))) + t))) + +;;;; Portable XREF from the CMU AI repository. + +(setq pxref::*handle-package-forms* '(cl:in-package)) + +(defmacro defxref (name function) + `(defimplementation ,name (name) + (xref-results (,function name)))) + +(defxref who-calls pxref:list-callers) +(defxref who-references pxref:list-readers) +(defxref who-binds pxref:list-setters) +(defxref who-sets pxref:list-setters) +(defxref list-callers pxref:list-callers) +(defxref list-callees pxref:list-callees) + +(defun xref-results (symbols) + (let ((xrefs '())) + (dolist (symbol symbols) + (push (fspec-location symbol symbol) xrefs)) + xrefs)) + +(when (find-package :swank-loader) + (setf (symbol-function (intern "USER-INIT-FILE" :swank-loader)) + (lambda () + (let ((home (user-homedir-pathname))) + (and (ext:probe-directory home) + (probe-file (format nil "~A/.swank.lisp" + (namestring (truename home))))))))) + +;;; Don't set *debugger-hook* to nil on break. +(ext:without-package-lock () + (defun break (&optional (format-string "Break") &rest args) + (if (not sys::*use-clcs*) + (progn + (terpri *error-output*) + (apply #'format *error-output* + (concatenate 'string "*** - " format-string) + args) + (funcall ext:*break-driver* t)) + (let ((condition + (make-condition 'simple-condition + :format-control format-string + :format-arguments args)) + ;;(*debugger-hook* nil) + ;; Issue 91 + ) + (ext:with-restarts + ((continue + :report (lambda (stream) + (format stream (sys::text "Return from ~S loop") + 'break)) + ())) + (with-condition-restarts condition (list (find-restart 'continue)) + (invoke-debugger condition))))) + nil)) + +;;;; Inspecting + +(defmethod emacs-inspect ((o t)) + (let* ((*print-array* nil) (*print-pretty* t) + (*print-circle* t) (*print-escape* t) + (*print-lines* custom:*inspect-print-lines*) + (*print-level* custom:*inspect-print-level*) + (*print-length* custom:*inspect-print-length*) + (sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t)) + (tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-"))) + (*package* tmp-pack) + (sys::*inspect-unbound-value* (intern "#<unbound>" tmp-pack))) + (let ((inspection (sys::inspect-backend o))) + (append (list + (format nil "~S~% ~A~{~%~A~}~%" o + (sys::insp-title inspection) + (sys::insp-blurb inspection))) + (loop with count = (sys::insp-num-slots inspection) + for i below count + append (multiple-value-bind (value name) + (funcall (sys::insp-nth-slot inspection) + i) + `((:value ,name) " = " (:value ,value) + (:newline)))))))) + +(defimplementation quit-lisp () + #+lisp=cl (ext:quit) + #-lisp=cl (lisp:quit)) + + +(defimplementation preferred-communication-style () + nil) + +;;; FIXME +;;; +;;; Clisp 2.48 added experimental support for threads. Basically, you +;;; can use :SPAWN now, BUT: +;;; +;;; - there are problems with GC, and threads stuffed into weak +;;; hash-tables as is the case for *THREAD-PLIST-TABLE*. +;;; +;;; See test case at +;;; http://thread.gmane.org/gmane.lisp.clisp.devel/20429 +;;; +;;; Even though said to be fixed, it's not: +;;; +;;; http://thread.gmane.org/gmane.lisp.clisp.devel/20429/focus=20443 +;;; +;;; - The DYNAMIC-FLET above is an implementation technique that's +;;; probably not sustainable in light of threads. This got to be +;;; rewritten. +;;; +;;; TCR (2009-07-30) + +#+#.(cl:if (cl:find-package "MP") '(:and) '(:or)) +(progn + (defimplementation spawn (fn &key name) + (mp:make-thread fn :name name)) + + (defvar *thread-plist-table-lock* + (mp:make-mutex :name "THREAD-PLIST-TABLE-LOCK")) + + (defvar *thread-plist-table* (make-hash-table :weak :key) + "A hashtable mapping threads to a plist.") + + (defvar *thread-id-counter* 0) + + (defimplementation thread-id (thread) + (mp:with-mutex-lock (*thread-plist-table-lock*) + (or (getf (gethash thread *thread-plist-table*) 'thread-id) + (setf (getf (gethash thread *thread-plist-table*) 'thread-id) + (incf *thread-id-counter*))))) + + (defimplementation find-thread (id) + (find id (all-threads) + :key (lambda (thread) + (getf (gethash thread *thread-plist-table*) 'thread-id)))) + + (defimplementation thread-name (thread) + ;; To guard against returning #<UNBOUND>. + (princ-to-string (mp:thread-name thread))) + + (defimplementation thread-status (thread) + (if (thread-alive-p thread) + "RUNNING" + "STOPPED")) + + (defimplementation make-lock (&key name) + (mp:make-mutex :name name :recursive-p t)) + + (defimplementation call-with-lock-held (lock function) + (mp:with-mutex-lock (lock) + (funcall function))) + + (defimplementation current-thread () + (mp:current-thread)) + + (defimplementation all-threads () + (mp:list-threads)) + + (defimplementation interrupt-thread (thread fn) + (mp:thread-interrupt thread :function fn)) + + (defimplementation kill-thread (thread) + (mp:thread-interrupt thread :function t)) + + (defimplementation thread-alive-p (thread) + (mp:thread-active-p thread)) + + (defvar *mailboxes-lock* (make-lock :name "MAILBOXES-LOCK")) + (defvar *mailboxes* (list)) + + (defstruct (mailbox (:conc-name mailbox.)) + thread + (lock (make-lock :name "MAILBOX.LOCK")) + (waitqueue (mp:make-exemption :name "MAILBOX.WAITQUEUE")) + (queue '() :type list)) + + (defun mailbox (thread) + "Return THREAD's mailbox." + (mp:with-mutex-lock (*mailboxes-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)) + (lock (mailbox.lock mbox))) + (mp:with-mutex-lock (lock) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + (mp:exemption-broadcast (mailbox.waitqueue mbox))))) + + (defimplementation receive-if (test &optional timeout) + (let* ((mbox (mailbox (current-thread))) + (lock (mailbox.lock mbox))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (mp:with-mutex-lock (lock) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail)))) + (when (eq timeout t) (return (values nil t))) + (mp:exemption-wait (mailbox.waitqueue mbox) lock :timeout 0.2)))))) + + +;;;; Weak hashtables + +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak :key args)) + +(defimplementation make-weak-value-hash-table (&rest args) + (apply #'make-hash-table :weak :value args)) + +(defimplementation save-image (filename &optional restart-function) + (let ((args `(,filename + ,@(if restart-function + `((:init-function ,restart-function)))))) + (apply #'ext:saveinitmem args))) diff --git a/vim/bundle/slimv/slime/swank/cmucl.lisp b/vim/bundle/slimv/slime/swank/cmucl.lisp new file mode 100644 index 0000000..12d4282 --- /dev/null +++ b/vim/bundle/slimv/slime/swank/cmucl.lisp @@ -0,0 +1,2470 @@ +;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*- +;;; +;;; License: Public Domain +;;; +;;;; Introduction +;;; +;;; This is the CMUCL implementation of the `swank/backend' package. + +(defpackage swank/cmucl + (:use cl swank/backend swank/source-path-parser swank/source-file-cache + fwrappers)) + +(in-package swank/cmucl) + +(eval-when (:compile-toplevel :load-toplevel :execute) + + (let ((min-version #x20c)) + (assert (>= c:byte-fasl-file-version min-version) + () "This file requires CMUCL version ~x or newer" min-version)) + + (require 'gray-streams)) + + +(import-swank-mop-symbols :pcl '(:slot-definition-documentation)) + +(defun swank-mop:slot-definition-documentation (slot) + (documentation slot t)) + +;;; UTF8 + +(locally (declare (optimize (ext:inhibit-warnings 3))) + ;; Compile and load the utf8 format, if not already loaded. + (stream::find-external-format :utf-8)) + +(defimplementation string-to-utf8 (string) + (let ((ef (load-time-value (stream::find-external-format :utf-8) t))) + (stream:string-to-octets string :external-format ef))) + +(defimplementation utf8-to-string (octets) + (let ((ef (load-time-value (stream::find-external-format :utf-8) t))) + (stream:octets-to-string octets :external-format ef))) + + +;;;; TCP server +;;; +;;; In CMUCL we support all communication styles. By default we use +;;; `:SIGIO' because it is the most responsive, but it's somewhat +;;; dangerous: CMUCL is not in general "signal safe", and you don't +;;; know for sure what you'll be interrupting. Both `:FD-HANDLER' and +;;; `:SPAWN' are reasonable alternatives. + +(defimplementation preferred-communication-style () + :sigio) + +#-(or darwin mips) +(defimplementation create-socket (host port &key backlog) + (let* ((addr (resolve-hostname host)) + (addr (if (not (find-symbol "SOCKET-ERROR" :ext)) + (ext:htonl addr) + addr))) + (ext:create-inet-listener port :stream :reuse-address t :host addr + :backlog (or backlog 5)))) + +;; There seems to be a bug in create-inet-listener on Mac/OSX and Irix. +#+(or darwin mips) +(defimplementation create-socket (host port &key backlog) + (declare (ignore host)) + (ext:create-inet-listener port :stream :reuse-address t)) + +(defimplementation local-port (socket) + (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket)))) + +(defimplementation close-socket (socket) + (let ((fd (socket-fd socket))) + (sys:invalidate-descriptor fd) + (ext:close-socket fd))) + +(defimplementation accept-connection (socket &key + external-format buffering timeout) + (declare (ignore timeout)) + (make-socket-io-stream (ext:accept-tcp-connection socket) + (ecase buffering + ((t) :full) + (:line :line) + ((nil) :none)) + external-format)) + +;;;;; Sockets + +(defimplementation socket-fd (socket) + "Return the filedescriptor for the socket represented by SOCKET." + (etypecase socket + (fixnum socket) + (sys:fd-stream (sys:fd-stream-fd socket)))) + +(defun resolve-hostname (hostname) + "Return the IP address of HOSTNAME as an integer (in host byte-order)." + (let ((hostent (ext:lookup-host-entry hostname))) + (car (ext:host-entry-addr-list hostent)))) + +(defvar *external-format-to-coding-system* + '((:iso-8859-1 "iso-latin-1-unix") + #+unicode + (:utf-8 "utf-8-unix"))) + +(defimplementation find-external-format (coding-system) + (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + +(defun make-socket-io-stream (fd buffering external-format) + "Create a new input/output fd-stream for FD." + (cond (external-format + (sys:make-fd-stream fd :input t :output t + :element-type 'character + :buffering buffering + :external-format external-format)) + (t + (sys:make-fd-stream fd :input t :output t + :element-type '(unsigned-byte 8) + :buffering buffering)))) + +(defimplementation make-fd-stream (fd external-format) + (make-socket-io-stream fd :full external-format)) + +(defimplementation dup (fd) + (multiple-value-bind (clone error) (unix:unix-dup fd) + (unless clone (error "dup failed: ~a" (unix:get-unix-error-msg error))) + clone)) + +(defimplementation command-line-args () + ext:*command-line-strings*) + +(defimplementation exec-image (image-file args) + (multiple-value-bind (ok error) + (unix:unix-execve (car (command-line-args)) + (list* (car (command-line-args)) + "-core" image-file + "-noinit" + args)) + (error "~a" (unix:get-unix-error-msg error)) + ok)) + +;;;;; Signal-driven I/O + +(defimplementation install-sigint-handler (function) + (sys:enable-interrupt :sigint (lambda (signal code scp) + (declare (ignore signal code scp)) + (funcall function)))) + +(defvar *sigio-handlers* '() + "List of (key . function) pairs. +All functions are called on SIGIO, and the key is used for removing +specific functions.") + +(defun reset-sigio-handlers () (setq *sigio-handlers* '())) +;; All file handlers are invalid afer reload. +(pushnew 'reset-sigio-handlers ext:*after-save-initializations*) + +(defun set-sigio-handler () + (sys:enable-interrupt :sigio (lambda (signal code scp) + (sigio-handler signal code scp)))) + +(defun sigio-handler (signal code scp) + (declare (ignore signal code scp)) + (mapc #'funcall (mapcar #'cdr *sigio-handlers*))) + +(defun fcntl (fd command arg) + "fcntl(2) - manipulate a file descriptor." + (multiple-value-bind (ok error) (unix:unix-fcntl fd command arg) + (cond (ok) + (t (error "fcntl: ~A" (unix:get-unix-error-msg error)))))) + +(defimplementation add-sigio-handler (socket fn) + (set-sigio-handler) + (let ((fd (socket-fd socket))) + (fcntl fd unix:f-setown (unix:unix-getpid)) + (let ((old-flags (fcntl fd unix:f-getfl 0))) + (fcntl fd unix:f-setfl (logior old-flags unix:fasync))) + (assert (not (assoc fd *sigio-handlers*))) + (push (cons fd fn) *sigio-handlers*))) + +(defimplementation remove-sigio-handlers (socket) + (let ((fd (socket-fd socket))) + (when (assoc fd *sigio-handlers*) + (setf *sigio-handlers* (remove fd *sigio-handlers* :key #'car)) + (let ((old-flags (fcntl fd unix:f-getfl 0))) + (fcntl fd unix:f-setfl (logandc2 old-flags unix:fasync))) + (sys:invalidate-descriptor fd)) + (assert (not (assoc fd *sigio-handlers*))) + (when (null *sigio-handlers*) + (sys:default-interrupt :sigio)))) + +;;;;; SERVE-EVENT + +(defimplementation add-fd-handler (socket fn) + (let ((fd (socket-fd socket))) + (sys:add-fd-handler fd :input (lambda (_) _ (funcall fn))))) + +(defimplementation remove-fd-handlers (socket) + (sys:invalidate-descriptor (socket-fd socket))) + +(defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (loop + (let ((ready (remove-if-not #'listen streams))) + (when ready (return ready))) + (when timeout (return nil)) + (multiple-value-bind (in out) (make-pipe) + (let* ((f (constantly t)) + (handlers (loop for s in (cons in (mapcar #'to-fd-stream streams)) + collect (add-one-shot-handler s f)))) + (unwind-protect + (let ((*interrupt-queued-handler* (lambda () + (write-char #\! out)))) + (when (check-slime-interrupts) (return :interrupt)) + (sys:serve-event)) + (mapc #'sys:remove-fd-handler handlers) + (close in) + (close out)))))) + +(defun to-fd-stream (stream) + (etypecase stream + (sys:fd-stream stream) + (synonym-stream + (to-fd-stream + (symbol-value (synonym-stream-symbol stream)))) + (two-way-stream + (to-fd-stream (two-way-stream-input-stream stream))))) + +(defun add-one-shot-handler (stream function) + (let (handler) + (setq handler (sys:add-fd-handler (sys:fd-stream-fd stream) :input + (lambda (fd) + (declare (ignore fd)) + (sys:remove-fd-handler handler) + (funcall function stream)))))) + +(defun make-pipe () + (multiple-value-bind (in out) (unix:unix-pipe) + (values (sys:make-fd-stream in :input t :buffering :none) + (sys:make-fd-stream out :output t :buffering :none)))) + + +;;;; Stream handling + +(defimplementation gray-package-name () + "EXT") + + +;;;; Compilation Commands + +(defvar *previous-compiler-condition* nil + "Used to detect duplicates.") + +(defvar *previous-context* nil + "Previous compiler error context.") + +(defvar *buffer-name* nil + "The name of the Emacs buffer we are compiling from. +NIL if we aren't compiling from a buffer.") + +(defvar *buffer-start-position* nil) +(defvar *buffer-substring* nil) + +(defimplementation call-with-compilation-hooks (function) + (let ((*previous-compiler-condition* nil) + (*previous-context* nil) + (*print-readably* nil)) + (handler-bind ((c::compiler-error #'handle-notification-condition) + (c::style-warning #'handle-notification-condition) + (c::warning #'handle-notification-condition)) + (funcall function)))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (clear-xref-info input-file) + (with-compilation-hooks () + (let ((*buffer-name* nil) + (ext:*ignore-extra-close-parentheses* nil)) + (multiple-value-bind (output-file warnings-p failure-p) + (compile-file input-file :output-file output-file + :external-format external-format) + (values output-file warnings-p + (or failure-p + (when load-p + ;; Cache the latest source file for definition-finding. + (source-cache-get input-file + (file-write-date input-file)) + (not (load output-file))))))))) + +(defimplementation swank-compile-string (string &key buffer position filename + policy) + (declare (ignore filename policy)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-start-position* position) + (*buffer-substring* string) + (source-info (list :emacs-buffer buffer + :emacs-buffer-offset position + :emacs-buffer-string string))) + (with-input-from-string (stream string) + (let ((failurep (ext:compile-from-stream stream :source-info + source-info))) + (not failurep)))))) + + +;;;;; Trapping notes +;;; +;;; We intercept conditions from the compiler and resignal them as +;;; `SWANK:COMPILER-CONDITION's. + +(defun handle-notification-condition (condition) + "Handle a condition caused by a compiler warning." + (unless (eq condition *previous-compiler-condition*) + (let ((context (c::find-error-context nil))) + (setq *previous-compiler-condition* condition) + (setq *previous-context* context) + (signal-compiler-condition condition context)))) + +(defun signal-compiler-condition (condition context) + (signal 'compiler-condition + :original-condition condition + :severity (severity-for-emacs condition) + :message (compiler-condition-message condition) + :source-context (compiler-error-context context) + :location (if (read-error-p condition) + (read-error-location condition) + (compiler-note-location context)))) + +(defun severity-for-emacs (condition) + "Return the severity of CONDITION." + (etypecase condition + ((satisfies read-error-p) :read-error) + (c::compiler-error :error) + (c::style-warning :note) + (c::warning :warning))) + +(defun read-error-p (condition) + (eq (type-of condition) 'c::compiler-read-error)) + +(defun compiler-condition-message (condition) + "Briefly describe a compiler error for Emacs. +When Emacs presents the message it already has the source popped up +and the source form highlighted. This makes much of the information in +the error-context redundant." + (princ-to-string condition)) + +(defun compiler-error-context (error-context) + "Describe context information for Emacs." + (declare (type (or c::compiler-error-context null) error-context)) + (multiple-value-bind (enclosing source) + (if error-context + (values (c::compiler-error-context-enclosing-source error-context) + (c::compiler-error-context-source error-context))) + (if (or enclosing source) + (format nil "~@[--> ~{~<~%--> ~1:;~A ~>~}~%~]~ + ~@[==>~{~&~A~}~]" + enclosing source)))) + +(defun read-error-location (condition) + (let* ((finfo (car (c::source-info-current-file c::*source-info*))) + (file (c::file-info-name finfo)) + (pos (c::compiler-read-error-position condition))) + (cond ((and (eq file :stream) *buffer-name*) + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-start-position* pos))) + ((and (pathnamep file) (not *buffer-name*)) + (make-location (list :file (unix-truename file)) + (list :position (1+ pos)))) + (t (break))))) + +(defun compiler-note-location (context) + "Derive the location of a complier message from its context. +Return a `location' record, or (:error REASON) on failure." + (if (null context) + (note-error-location) + (with-struct (c::compiler-error-context- file-name + original-source + original-source-path) context + (or (locate-compiler-note file-name original-source + (reverse original-source-path)) + (note-error-location))))) + +(defun note-error-location () + "Pseudo-location for notes that can't be located." + (cond (*compile-file-truename* + (make-location (list :file (unix-truename *compile-file-truename*)) + (list :eof))) + (*buffer-name* + (make-location (list :buffer *buffer-name*) + (list :position *buffer-start-position*))) + (t (list :error "No error location available.")))) + +(defun locate-compiler-note (file source source-path) + (cond ((and (eq file :stream) *buffer-name*) + ;; Compiling from a buffer + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-start-position* + (source-path-string-position + source-path *buffer-substring*)))) + ((and (pathnamep file) (null *buffer-name*)) + ;; Compiling from a file + (make-location (list :file (unix-truename file)) + (list :position (1+ (source-path-file-position + source-path file))))) + ((and (eq file :lisp) (stringp source)) + ;; No location known, but we have the source form. + ;; XXX How is this case triggered? -luke (16/May/2004) + ;; This can happen if the compiler needs to expand a macro + ;; but the macro-expander is not yet compiled. Calling the + ;; (interpreted) macro-expander triggers IR1 conversion of + ;; the lambda expression for the expander and invokes the + ;; compiler recursively. + (make-location (list :source-form source) + (list :position 1))))) + +(defun unix-truename (pathname) + (ext:unix-namestring (truename pathname))) + + +;;;; XREF +;;; +;;; Cross-reference support is based on the standard CMUCL `XREF' +;;; package. This package has some caveats: XREF information is +;;; recorded during compilation and not preserved in fasl files, and +;;; XREF recording is disabled by default. Redefining functions can +;;; also cause duplicate references to accumulate, but +;;; `swank-compile-file' will automatically clear out any old records +;;; from the same filename. +;;; +;;; To enable XREF recording, set `c:*record-xref-info*' to true. To +;;; clear out the XREF database call `xref:init-xref-database'. + +(defmacro defxref (name function) + `(defimplementation ,name (name) + (xref-results (,function name)))) + +(defxref who-calls xref:who-calls) +(defxref who-references xref:who-references) +(defxref who-binds xref:who-binds) +(defxref who-sets xref:who-sets) + +;;; More types of XREF information were added since 18e: +;;; + +(defxref who-macroexpands xref:who-macroexpands) +;; XXX +(defimplementation who-specializes (symbol) + (let* ((methods (xref::who-specializes (find-class symbol))) + (locations (mapcar #'method-location methods))) + (mapcar #'list methods locations))) + +(defun xref-results (contexts) + (mapcar (lambda (xref) + (list (xref:xref-context-name xref) + (resolve-xref-location xref))) + contexts)) + +(defun resolve-xref-location (xref) + (let ((name (xref:xref-context-name xref)) + (file (xref:xref-context-file xref)) + (source-path (xref:xref-context-source-path xref))) + (cond ((and file source-path) + (let ((position (source-path-file-position source-path file))) + (make-location (list :file (unix-truename file)) + (list :position (1+ position))))) + (file + (make-location (list :file (unix-truename file)) + (list :function-name (string name)))) + (t + `(:error ,(format nil "Unknown source location: ~S ~S ~S " + name file source-path)))))) + +(defun clear-xref-info (namestring) + "Clear XREF notes pertaining to NAMESTRING. +This is a workaround for a CMUCL bug: XREF records are cumulative." + (when c:*record-xref-info* + (let ((filename (truename namestring))) + (dolist (db (list xref::*who-calls* + xref::*who-is-called* + xref::*who-macroexpands* + xref::*who-references* + xref::*who-binds* + xref::*who-sets*)) + (maphash (lambda (target contexts) + ;; XXX update during traversal? + (setf (gethash target db) + (delete filename contexts + :key #'xref:xref-context-file + :test #'equalp))) + db))))) + + +;;;; Find callers and callees +;;; +;;; Find callers and callees by looking at the constant pool of +;;; compiled code objects. We assume every fdefn object in the +;;; constant pool corresponds to a call to that function. A better +;;; strategy would be to use the disassembler to find actual +;;; call-sites. + +(labels ((make-stack () (make-array 100 :fill-pointer 0 :adjustable t)) + (map-cpool (code fun) + (declare (type kernel:code-component code) (type function fun)) + (loop for i from vm:code-constants-offset + below (kernel:get-header-data code) + do (funcall fun (kernel:code-header-ref code i)))) + + (callees (fun) + (let ((callees (make-stack))) + (map-cpool (vm::find-code-object fun) + (lambda (o) + (when (kernel:fdefn-p o) + (vector-push-extend (kernel:fdefn-function o) + callees)))) + (coerce callees 'list))) + + (callers (fun) + (declare (function fun)) + (let ((callers (make-stack))) + (ext:gc :full t) + ;; scan :dynamic first to avoid the need for even more gcing + (dolist (space '(:dynamic :read-only :static)) + (vm::map-allocated-objects + (lambda (obj header size) + (declare (type fixnum header) (ignore size)) + (when (= vm:code-header-type header) + (map-cpool obj + (lambda (c) + (when (and (kernel:fdefn-p c) + (eq (kernel:fdefn-function c) fun)) + (vector-push-extend obj callers)))))) + space) + (ext:gc)) + (coerce callers 'list))) + + (entry-points (code) + (loop for entry = (kernel:%code-entry-points code) + then (kernel::%function-next entry) + while entry + collect entry)) + + (guess-main-entry-point (entry-points) + (or (find-if (lambda (fun) + (ext:valid-function-name-p + (kernel:%function-name fun))) + entry-points) + (car entry-points))) + + (fun-dspec (fun) + (list (kernel:%function-name fun) (function-location fun))) + + (code-dspec (code) + (let ((eps (entry-points code)) + (di (kernel:%code-debug-info code))) + (cond (eps (fun-dspec (guess-main-entry-point eps))) + (di (list (c::debug-info-name di) + (debug-info-function-name-location di))) + (t (list (princ-to-string code) + `(:error "No src-loc available"))))))) + (declare (inline map-cpool)) + + (defimplementation list-callers (symbol) + (mapcar #'code-dspec (callers (coerce symbol 'function) ))) + + (defimplementation list-callees (symbol) + (mapcar #'fun-dspec (callees symbol)))) + +(defun test-list-callers (count) + (let ((funsyms '())) + (do-all-symbols (s) + (when (and (fboundp s) + (functionp (symbol-function s)) + (not (macro-function s)) + (not (special-operator-p s))) + (push s funsyms))) + (let ((len (length funsyms))) + (dotimes (i count) + (let ((sym (nth (random len) funsyms))) + (format t "~s -> ~a~%" sym (mapcar #'car (list-callers sym)))))))) + +;; (test-list-callers 100) + + +;;;; Resolving source locations +;;; +;;; Our mission here is to "resolve" references to code locations into +;;; actual file/buffer names and character positions. The references +;;; we work from come out of the compiler's statically-generated debug +;;; information, such as `code-location''s and `debug-source''s. For +;;; more details, see the "Debugger Programmer's Interface" section of +;;; the CMUCL manual. +;;; +;;; The first step is usually to find the corresponding "source-path" +;;; for the location. Once we have the source-path we can pull up the +;;; source file and `READ' our way through to the right position. The +;;; main source-code groveling work is done in +;;; `source-path-parser.lisp'. + +(defvar *debug-definition-finding* nil + "When true don't handle errors while looking for definitions. +This is useful when debugging the definition-finding code.") + +(defmacro safe-definition-finding (&body body) + "Execute BODY and return the source-location it returns. +If an error occurs and `*debug-definition-finding*' is false, then +return an error pseudo-location. + +The second return value is NIL if no error occurs, otherwise it is the +condition object." + `(flet ((body () ,@body)) + (if *debug-definition-finding* + (body) + (handler-case (values (progn ,@body) nil) + (error (c) (values `(:error ,(trim-whitespace (princ-to-string c))) + c)))))) + +(defun trim-whitespace (string) + (string-trim #(#\newline #\space #\tab) string)) + +(defun code-location-source-location (code-location) + "Safe wrapper around `code-location-from-source-location'." + (safe-definition-finding + (source-location-from-code-location code-location))) + +(defun source-location-from-code-location (code-location) + "Return the source location for CODE-LOCATION." + (let ((debug-fun (di:code-location-debug-function code-location))) + (when (di::bogus-debug-function-p debug-fun) + ;; Those lousy cheapskates! They've put in a bogus debug source + ;; because the code was compiled at a low debug setting. + (error "Bogus debug function: ~A" debug-fun))) + (let* ((debug-source (di:code-location-debug-source code-location)) + (from (di:debug-source-from debug-source)) + (name (di:debug-source-name debug-source))) + (ecase from + (:file + (location-in-file name code-location debug-source)) + (:stream + (location-in-stream code-location debug-source)) + (:lisp + ;; The location comes from a form passed to `compile'. + ;; The best we can do is return the form itself for printing. + (make-location + (list :source-form (with-output-to-string (*standard-output*) + (debug::print-code-location-source-form + code-location 100 t))) + (list :position 1)))))) + +(defun location-in-file (filename code-location debug-source) + "Resolve the source location for CODE-LOCATION in FILENAME." + (let* ((code-date (di:debug-source-created debug-source)) + (root-number (di:debug-source-root-number debug-source)) + (source-code (get-source-code filename code-date))) + (with-input-from-string (s source-code) + (make-location (list :file (unix-truename filename)) + (list :position (1+ (code-location-stream-position + code-location s root-number))) + `(:snippet ,(read-snippet s)))))) + +(defun location-in-stream (code-location debug-source) + "Resolve the source location for a CODE-LOCATION from a stream. +This only succeeds if the code was compiled from an Emacs buffer." + (unless (debug-source-info-from-emacs-buffer-p debug-source) + (error "The code is compiled from a non-SLIME stream.")) + (let* ((info (c::debug-source-info debug-source)) + (string (getf info :emacs-buffer-string)) + (position (code-location-string-offset + code-location + string))) + (make-location + (list :buffer (getf info :emacs-buffer)) + (list :offset (getf info :emacs-buffer-offset) position) + (list :snippet (with-input-from-string (s string) + (file-position s position) + (read-snippet s)))))) + +;;;;; Function-name locations +;;; +(defun debug-info-function-name-location (debug-info) + "Return a function-name source-location for DEBUG-INFO. +Function-name source-locations are a fallback for when precise +positions aren't available." + (with-struct (c::debug-info- (fname name) source) debug-info + (with-struct (c::debug-source- info from name) (car source) + (ecase from + (:file + (make-location (list :file (namestring (truename name))) + (list :function-name (string fname)))) + (:stream + (assert (debug-source-info-from-emacs-buffer-p (car source))) + (make-location (list :buffer (getf info :emacs-buffer)) + (list :function-name (string fname)))) + (:lisp + (make-location (list :source-form (princ-to-string (aref name 0))) + (list :position 1))))))) + +(defun debug-source-info-from-emacs-buffer-p (debug-source) + "Does the `info' slot of DEBUG-SOURCE contain an Emacs buffer location? +This is true for functions that were compiled directly from buffers." + (info-from-emacs-buffer-p (c::debug-source-info debug-source))) + +(defun info-from-emacs-buffer-p (info) + (and info + (consp info) + (eq :emacs-buffer (car info)))) + + +;;;;; Groveling source-code for positions + +(defun code-location-stream-position (code-location stream root) + "Return the byte offset of CODE-LOCATION in STREAM. Extract the +toplevel-form-number and form-number from CODE-LOCATION and use that +to find the position of the corresponding form. + +Finish with STREAM positioned at the start of the code location." + (let* ((location (debug::maybe-block-start-location code-location)) + (tlf-offset (- (di:code-location-top-level-form-offset location) + root)) + (form-number (di:code-location-form-number location))) + (let ((pos (form-number-stream-position tlf-offset form-number stream))) + (file-position stream pos) + pos))) + +(defun form-number-stream-position (tlf-number form-number stream) + "Return the starting character position of a form in STREAM. +TLF-NUMBER is the top-level-form number. +FORM-NUMBER is an index into a source-path table for the TLF." + (multiple-value-bind (tlf position-map) (read-source-form tlf-number stream) + (let* ((path-table (di:form-number-translations tlf 0)) + (source-path + (if (<= (length path-table) form-number) ; source out of sync? + (list 0) ; should probably signal a condition + (reverse (cdr (aref path-table form-number)))))) + (source-path-source-position source-path tlf position-map)))) + +(defun code-location-string-offset (code-location string) + "Return the byte offset of CODE-LOCATION in STRING. +See CODE-LOCATION-STREAM-POSITION." + (with-input-from-string (s string) + (code-location-stream-position code-location s 0))) + + +;;;; Finding definitions + +;;; There are a great many different types of definition for us to +;;; find. We search for definitions of every kind and return them in a +;;; list. + +(defimplementation find-definitions (name) + (append (function-definitions name) + (setf-definitions name) + (variable-definitions name) + (class-definitions name) + (type-definitions name) + (compiler-macro-definitions name) + (source-transform-definitions name) + (function-info-definitions name) + (ir1-translator-definitions name) + (template-definitions name) + (primitive-definitions name) + (vm-support-routine-definitions name) + )) + +;;;;; Functions, macros, generic functions, methods +;;; +;;; We make extensive use of the compile-time debug information that +;;; CMUCL records, in particular "debug functions" and "code +;;; locations." Refer to the "Debugger Programmer's Interface" section +;;; of the CMUCL manual for more details. + +(defun function-definitions (name) + "Return definitions for NAME in the \"function namespace\", i.e., +regular functions, generic functions, methods and macros. +NAME can any valid function name (e.g, (setf car))." + (let ((macro? (and (symbolp name) (macro-function name))) + (function? (and (ext:valid-function-name-p name) + (ext:info :function :definition name) + (if (symbolp name) (fboundp name) t)))) + (cond (macro? + (list `((defmacro ,name) + ,(function-location (macro-function name))))) + (function? + (let ((function (fdefinition name))) + (if (genericp function) + (gf-definitions name function) + (list (list `(function ,name) + (function-location function))))))))) + +;;;;;; Ordinary (non-generic/macro/special) functions +;;; +;;; First we test if FUNCTION is a closure created by defstruct, and +;;; if so extract the defstruct-description (`dd') from the closure +;;; and find the constructor for the struct. Defstruct creates a +;;; defun for the default constructor and we use that as an +;;; approximation to the source location of the defstruct. +;;; +;;; For an ordinary function we return the source location of the +;;; first code-location we find. +;;; +(defun function-location (function) + "Return the source location for FUNCTION." + (cond ((struct-closure-p function) + (struct-closure-location function)) + ((c::byte-function-or-closure-p function) + (byte-function-location function)) + (t + (compiled-function-location function)))) + +(defun compiled-function-location (function) + "Return the location of a regular compiled function." + (multiple-value-bind (code-location error) + (safe-definition-finding (function-first-code-location function)) + (cond (error (list :error (princ-to-string error))) + (t (code-location-source-location code-location))))) + +(defun function-first-code-location (function) + "Return the first code-location we can find for FUNCTION." + (and (function-has-debug-function-p function) + (di:debug-function-start-location + (di:function-debug-function function)))) + +(defun function-has-debug-function-p (function) + (di:function-debug-function function)) + +(defun function-code-object= (closure function) + (and (eq (vm::find-code-object closure) + (vm::find-code-object function)) + (not (eq closure function)))) + +(defun byte-function-location (fun) + "Return the location of the byte-compiled function FUN." + (etypecase fun + ((or c::hairy-byte-function c::simple-byte-function) + (let* ((di (kernel:%code-debug-info (c::byte-function-component fun)))) + (if di + (debug-info-function-name-location di) + `(:error + ,(format nil "Byte-function without debug-info: ~a" fun))))) + (c::byte-closure + (byte-function-location (c::byte-closure-function fun))))) + +;;; Here we deal with structure accessors. Note that `dd' is a +;;; "defstruct descriptor" structure in CMUCL. A `dd' describes a +;;; `defstruct''d structure. + +(defun struct-closure-p (function) + "Is FUNCTION a closure created by defstruct?" + (or (function-code-object= function #'kernel::structure-slot-accessor) + (function-code-object= function #'kernel::structure-slot-setter) + (function-code-object= function #'kernel::%defstruct))) + +(defun struct-closure-location (function) + "Return the location of the structure that FUNCTION belongs to." + (assert (struct-closure-p function)) + (safe-definition-finding + (dd-location (struct-closure-dd function)))) + +(defun struct-closure-dd (function) + "Return the defstruct-definition (dd) of FUNCTION." + (assert (= (kernel:get-type function) vm:closure-header-type)) + (flet ((find-layout (function) + (sys:find-if-in-closure + (lambda (x) + (let ((value (if (di::indirect-value-cell-p x) + (c:value-cell-ref x) + x))) + (when (kernel::layout-p value) + (return-from find-layout value)))) + function))) + (kernel:layout-info (find-layout function)))) + +(defun dd-location (dd) + "Return the location of a `defstruct'." + (let ((ctor (struct-constructor dd))) + (cond (ctor + (function-location (coerce ctor 'function))) + (t + (let ((name (kernel:dd-name dd))) + (multiple-value-bind (location foundp) + (ext:info :source-location :defvar name) + (cond (foundp + (resolve-source-location location)) + (t + (error "No location for defstruct: ~S" name))))))))) + +(defun struct-constructor (dd) + "Return the name of the constructor from a defstruct definition." + (let* ((constructor (or (kernel:dd-default-constructor dd) + (car (kernel::dd-constructors dd))))) + (if (consp constructor) (car constructor) constructor))) + +;;;;;; Generic functions and methods + +(defun gf-definitions (name function) + "Return the definitions of a generic function and its methods." + (cons (list `(defgeneric ,name) (gf-location function)) + (gf-method-definitions function))) + +(defun gf-location (gf) + "Return the location of the generic function GF." + (definition-source-location gf (pcl::generic-function-name gf))) + +(defun gf-method-definitions (gf) + "Return the locations of all methods of the generic function GF." + (mapcar #'method-definition (pcl::generic-function-methods gf))) + +(defun method-definition (method) + (list (method-dspec method) + (method-location method))) + +(defun method-dspec (method) + "Return a human-readable \"definition specifier\" for METHOD." + (let* ((gf (pcl:method-generic-function method)) + (name (pcl:generic-function-name gf)) + (specializers (pcl:method-specializers method)) + (qualifiers (pcl:method-qualifiers method))) + `(method ,name ,@qualifiers ,(pcl::unparse-specializers specializers)))) + +(defun method-location (method) + (typecase method + (pcl::standard-accessor-method + (definition-source-location + (cond ((pcl::definition-source method) + method) + (t + (pcl::slot-definition-class + (pcl::accessor-method-slot-definition method)))) + (pcl::accessor-method-slot-name method))) + (t + (function-location (or (pcl::method-fast-function method) + (pcl:method-function method)))))) + +(defun genericp (fn) + (typep fn 'generic-function)) + +;;;;;; Types and classes + +(defun type-definitions (name) + "Return `deftype' locations for type NAME." + (maybe-make-definition (ext:info :type :expander name) 'deftype name)) + +(defun maybe-make-definition (function kind name) + "If FUNCTION is non-nil then return its definition location." + (if function + (list (list `(,kind ,name) (function-location function))))) + +(defun class-definitions (name) + "Return the definition locations for the class called NAME." + (if (symbolp name) + (let ((class (kernel::find-class name nil))) + (etypecase class + (null '()) + (kernel::structure-class + (list (list `(defstruct ,name) (dd-location (find-dd name))))) + #+(or) + (conditions::condition-class + (list (list `(define-condition ,name) + (condition-class-location class)))) + (kernel::standard-class + (list (list `(defclass ,name) + (pcl-class-location (find-class name))))) + ((or kernel::built-in-class + conditions::condition-class + kernel:funcallable-structure-class) + (list (list `(class ,name) (class-location class)))))))) + +(defun pcl-class-location (class) + "Return the `defclass' location for CLASS." + (definition-source-location class (pcl:class-name class))) + +;; FIXME: eval used for backward compatibility. +(defun class-location (class) + (declare (type kernel::class class)) + (let ((name (kernel:%class-name class))) + (multiple-value-bind (loc found?) + (let ((x (ignore-errors + (multiple-value-list + (eval `(ext:info :source-location :class ',name)))))) + (values-list x)) + (cond (found? (resolve-source-location loc)) + (`(:error + ,(format nil "No location recorded for class: ~S" name))))))) + +(defun find-dd (name) + "Find the defstruct-definition by the name of its structure-class." + (let ((layout (ext:info :type :compiler-layout name))) + (if layout + (kernel:layout-info layout)))) + +(defun condition-class-location (class) + (let ((slots (conditions::condition-class-slots class)) + (name (conditions::condition-class-name class))) + (cond ((null slots) + `(:error ,(format nil "No location info for condition: ~A" name))) + (t + ;; Find the class via one of its slot-reader methods. + (let* ((slot (first slots)) + (gf (fdefinition + (first (conditions::condition-slot-readers slot))))) + (method-location + (first + (pcl:compute-applicable-methods-using-classes + gf (list (find-class name)))))))))) + +(defun make-name-in-file-location (file string) + (multiple-value-bind (filename c) + (ignore-errors + (unix-truename (merge-pathnames (make-pathname :type "lisp") + file))) + (cond (filename (make-location `(:file ,filename) + `(:function-name ,(string string)))) + (t (list :error (princ-to-string c)))))) + +(defun source-location-form-numbers (location) + (c::decode-form-numbers (c::form-numbers-form-numbers location))) + +(defun source-location-tlf-number (location) + (nth-value 0 (source-location-form-numbers location))) + +(defun source-location-form-number (location) + (nth-value 1 (source-location-form-numbers location))) + +(defun resolve-file-source-location (location) + (let ((filename (c::file-source-location-pathname location)) + (tlf-number (source-location-tlf-number location)) + (form-number (source-location-form-number location))) + (with-open-file (s filename) + (let ((pos (form-number-stream-position tlf-number form-number s))) + (make-location `(:file ,(unix-truename filename)) + `(:position ,(1+ pos))))))) + +(defun resolve-stream-source-location (location) + (let ((info (c::stream-source-location-user-info location)) + (tlf-number (source-location-tlf-number location)) + (form-number (source-location-form-number location))) + ;; XXX duplication in frame-source-location + (assert (info-from-emacs-buffer-p info)) + (destructuring-bind (&key emacs-buffer emacs-buffer-string + emacs-buffer-offset) info + (with-input-from-string (s emacs-buffer-string) + (let ((pos (form-number-stream-position tlf-number form-number s))) + (make-location `(:buffer ,emacs-buffer) + `(:offset ,emacs-buffer-offset ,pos))))))) + +;; XXX predicates for 18e backward compatibilty. Remove them when +;; we're 19a only. +(defun file-source-location-p (object) + (when (fboundp 'c::file-source-location-p) + (c::file-source-location-p object))) + +(defun stream-source-location-p (object) + (when (fboundp 'c::stream-source-location-p) + (c::stream-source-location-p object))) + +(defun source-location-p (object) + (or (file-source-location-p object) + (stream-source-location-p object))) + +(defun resolve-source-location (location) + (etypecase location + ((satisfies file-source-location-p) + (resolve-file-source-location location)) + ((satisfies stream-source-location-p) + (resolve-stream-source-location location)))) + +(defun definition-source-location (object name) + (let ((source (pcl::definition-source object))) + (etypecase source + (null + `(:error ,(format nil "No source info for: ~A" object))) + ((satisfies source-location-p) + (resolve-source-location source)) + (pathname + (make-name-in-file-location source name)) + (cons + (destructuring-bind ((dg name) pathname) source + (declare (ignore dg)) + (etypecase pathname + (pathname (make-name-in-file-location pathname (string name))) + (null `(:error ,(format nil "Cannot resolve: ~S" source))))))))) + +(defun setf-definitions (name) + (let ((f (or (ext:info :setf :inverse name) + (ext:info :setf :expander name) + (and (symbolp name) + (fboundp `(setf ,name)) + (fdefinition `(setf ,name)))))) + (if f + `(((setf ,name) ,(function-location (cond ((functionp f) f) + ((macro-function f)) + ((fdefinition f))))))))) + +(defun variable-location (symbol) + (multiple-value-bind (location foundp) + ;; XXX for 18e compatibilty. rewrite this when we drop 18e + ;; support. + (ignore-errors (eval `(ext:info :source-location :defvar ',symbol))) + (if (and foundp location) + (resolve-source-location location) + `(:error ,(format nil "No source info for variable ~S" symbol))))) + +(defun variable-definitions (name) + (if (symbolp name) + (multiple-value-bind (kind recorded-p) (ext:info :variable :kind name) + (if recorded-p + (list (list `(variable ,kind ,name) + (variable-location name))))))) + +(defun compiler-macro-definitions (symbol) + (maybe-make-definition (compiler-macro-function symbol) + 'define-compiler-macro + symbol)) + +(defun source-transform-definitions (name) + (maybe-make-definition (ext:info :function :source-transform name) + 'c:def-source-transform + name)) + +(defun function-info-definitions (name) + (let ((info (ext:info :function :info name))) + (if info + (append (loop for transform in (c::function-info-transforms info) + collect (list `(c:deftransform ,name + ,(c::type-specifier + (c::transform-type transform))) + (function-location (c::transform-function + transform)))) + (maybe-make-definition (c::function-info-derive-type info) + 'c::derive-type name) + (maybe-make-definition (c::function-info-optimizer info) + 'c::optimizer name) + (maybe-make-definition (c::function-info-ltn-annotate info) + 'c::ltn-annotate name) + (maybe-make-definition (c::function-info-ir2-convert info) + 'c::ir2-convert name) + (loop for template in (c::function-info-templates info) + collect (list `(,(type-of template) + ,(c::template-name template)) + (function-location + (c::vop-info-generator-function + template)))))))) + +(defun ir1-translator-definitions (name) + (maybe-make-definition (ext:info :function :ir1-convert name) + 'c:def-ir1-translator name)) + +(defun template-definitions (name) + (let* ((templates (c::backend-template-names c::*backend*)) + (template (gethash name templates))) + (etypecase template + (null) + (c::vop-info + (maybe-make-definition (c::vop-info-generator-function template) + (type-of template) name))))) + +;; for cases like: (%primitive NAME ...) +(defun primitive-definitions (name) + (let ((csym (find-symbol (string name) 'c))) + (and csym + (not (eq csym name)) + (template-definitions csym)))) + +(defun vm-support-routine-definitions (name) + (let ((sr (c::backend-support-routines c::*backend*)) + (name (find-symbol (string name) 'c))) + (and name + (slot-exists-p sr name) + (maybe-make-definition (slot-value sr name) + (find-symbol (string 'vm-support-routine) 'c) + name)))) + + +;;;; Documentation. + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind) + (or (documentation symbol kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (multiple-value-bind (kind recorded-p) + (ext:info variable kind symbol) + (declare (ignore kind)) + (if (or (boundp symbol) recorded-p) + (doc 'variable)))) + (when (fboundp symbol) + (maybe-push + (cond ((macro-function symbol) :macro) + ((special-operator-p symbol) :special-operator) + ((genericp (fdefinition symbol)) :generic-function) + (t :function)) + (doc 'function))) + (maybe-push + :setf (if (or (ext:info setf inverse symbol) + (ext:info setf expander symbol)) + (doc 'setf))) + (maybe-push + :type (if (ext:info type kind symbol) + (doc 'type))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + (maybe-push + :alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown)) + (doc 'alien-type))) + (maybe-push + :alien-struct (if (ext:info alien-type struct symbol) + (doc nil))) + (maybe-push + :alien-union (if (ext:info alien-type union symbol) + (doc nil))) + (maybe-push + :alien-enum (if (ext:info alien-type enum symbol) + (doc nil))) + result))) + +(defimplementation describe-definition (symbol namespace) + (describe (ecase namespace + (:variable + symbol) + ((:function :generic-function) + (symbol-function symbol)) + (:setf + (or (ext:info setf inverse symbol) + (ext:info setf expander symbol))) + (:type + (kernel:values-specifier-type symbol)) + (:class + (find-class symbol)) + (:alien-struct + (ext:info :alien-type :struct symbol)) + (:alien-union + (ext:info :alien-type :union symbol)) + (:alien-enum + (ext:info :alien-type :enum symbol)) + (:alien-type + (ecase (ext:info :alien-type :kind symbol) + (:primitive + (let ((alien::*values-type-okay* t)) + (funcall (ext:info :alien-type :translator symbol) + (list symbol)))) + ((:defined) + (ext:info :alien-type :definition symbol)) + (:unknown :unkown)))))) + +;;;;; Argument lists + +(defimplementation arglist (fun) + (etypecase fun + (function (function-arglist fun)) + (symbol (function-arglist (or (macro-function fun) + (symbol-function fun)))))) + +(defun function-arglist (fun) + (let ((arglist + (cond ((eval:interpreted-function-p fun) + (eval:interpreted-function-arglist fun)) + ((pcl::generic-function-p fun) + (pcl:generic-function-lambda-list fun)) + ((c::byte-function-or-closure-p fun) + (byte-code-function-arglist fun)) + ((kernel:%function-arglist (kernel:%function-self fun)) + (handler-case (read-arglist fun) + (error () :not-available))) + ;; this should work both for compiled-debug-function + ;; and for interpreted-debug-function + (t + (handler-case (debug-function-arglist + (di::function-debug-function fun)) + (di:unhandled-condition () :not-available)))))) + (check-type arglist (or list (member :not-available))) + arglist)) + +(defimplementation function-name (function) + (cond ((eval:interpreted-function-p function) + (eval:interpreted-function-name function)) + ((pcl::generic-function-p function) + (pcl::generic-function-name function)) + ((c::byte-function-or-closure-p function) + (c::byte-function-name function)) + (t (kernel:%function-name (kernel:%function-self function))))) + +;;; A simple case: the arglist is available as a string that we can +;;; `read'. + +(defun read-arglist (fn) + "Parse the arglist-string of the function object FN." + (let ((string (kernel:%function-arglist + (kernel:%function-self fn))) + (package (find-package + (c::compiled-debug-info-package + (kernel:%code-debug-info + (vm::find-code-object fn)))))) + (with-standard-io-syntax + (let ((*package* (or package *package*))) + (read-from-string string))))) + +;;; A harder case: an approximate arglist is derived from available +;;; debugging information. + +(defun debug-function-arglist (debug-function) + "Derive the argument list of DEBUG-FUNCTION from debug info." + (let ((args (di::debug-function-lambda-list debug-function)) + (required '()) + (optional '()) + (rest '()) + (key '())) + ;; collect the names of debug-vars + (dolist (arg args) + (etypecase arg + (di::debug-variable + (push (di::debug-variable-symbol arg) required)) + ((member :deleted) + (push ':deleted required)) + (cons + (ecase (car arg) + (:keyword + (push (second arg) key)) + (:optional + (push (debug-variable-symbol-or-deleted (second arg)) optional)) + (:rest + (push (debug-variable-symbol-or-deleted (second arg)) rest)))))) + ;; intersperse lambda keywords as needed + (append (nreverse required) + (if optional (cons '&optional (nreverse optional))) + (if rest (cons '&rest (nreverse rest))) + (if key (cons '&key (nreverse key)))))) + +(defun debug-variable-symbol-or-deleted (var) + (etypecase var + (di:debug-variable + (di::debug-variable-symbol var)) + ((member :deleted) + '#:deleted))) + +(defun symbol-debug-function-arglist (fname) + "Return FNAME's debug-function-arglist and %function-arglist. +A utility for debugging DEBUG-FUNCTION-ARGLIST." + (let ((fn (fdefinition fname))) + (values (debug-function-arglist (di::function-debug-function fn)) + (kernel:%function-arglist (kernel:%function-self fn))))) + +;;; Deriving arglists for byte-compiled functions: +;;; +(defun byte-code-function-arglist (fn) + ;; There doesn't seem to be much arglist information around for + ;; byte-code functions. Use the arg-count and return something like + ;; (arg0 arg1 ...) + (etypecase fn + (c::simple-byte-function + (loop for i from 0 below (c::simple-byte-function-num-args fn) + collect (make-arg-symbol i))) + (c::hairy-byte-function + (hairy-byte-function-arglist fn)) + (c::byte-closure + (byte-code-function-arglist (c::byte-closure-function fn))))) + +(defun make-arg-symbol (i) + (make-symbol (format nil "~A~D" (string 'arg) i))) + +;;; A "hairy" byte-function is one that takes a variable number of +;;; arguments. `hairy-byte-function' is a type from the bytecode +;;; interpreter. +;;; +(defun hairy-byte-function-arglist (fn) + (let ((counter -1)) + (flet ((next-arg () (make-arg-symbol (incf counter)))) + (with-struct (c::hairy-byte-function- min-args max-args rest-arg-p + keywords-p keywords) fn + (let ((arglist '()) + (optional (- max-args min-args))) + ;; XXX isn't there a better way to write this? + ;; (Looks fine to me. -luke) + (dotimes (i min-args) + (push (next-arg) arglist)) + (when (plusp optional) + (push '&optional arglist) + (dotimes (i optional) + (push (next-arg) arglist))) + (when rest-arg-p + (push '&rest arglist) + (push (next-arg) arglist)) + (when keywords-p + (push '&key arglist) + (loop for (key _ __) in keywords + do (push key arglist)) + (when (eq keywords-p :allow-others) + (push '&allow-other-keys arglist))) + (nreverse arglist)))))) + + +;;;; Miscellaneous. + +(defimplementation macroexpand-all (form &optional env) + (walker:macroexpand-all form env)) + +(defimplementation compiler-macroexpand-1 (form &optional env) + (ext:compiler-macroexpand-1 form env)) + +(defimplementation compiler-macroexpand (form &optional env) + (ext:compiler-macroexpand form env)) + +(defimplementation set-default-directory (directory) + (setf (ext:default-directory) (namestring directory)) + ;; Setting *default-pathname-defaults* to an absolute directory + ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive. + (setf *default-pathname-defaults* (pathname (ext:default-directory))) + (default-directory)) + +(defimplementation default-directory () + (namestring (ext:default-directory))) + +(defimplementation getpid () + (unix:unix-getpid)) + +(defimplementation lisp-implementation-type-name () + "cmucl") + +(defimplementation quit-lisp () + (ext::quit)) + +;;; source-path-{stream,file,string,etc}-position moved into +;;; source-path-parser + + +;;;; Debugging + +(defvar *sldb-stack-top*) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (unix:unix-sigsetmask 0) + (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame))) + (debug:*stack-top-hint* nil) + (kernel:*current-level* 0)) + (handler-bind ((di::unhandled-condition + (lambda (condition) + (error 'sldb-condition + :original-condition condition)))) + (unwind-protect + (progn + #+(or)(sys:scrub-control-stack) + (funcall debugger-loop-fn)) + #+(or)(sys:scrub-control-stack) + )))) + +(defun frame-down (frame) + (handler-case (di:frame-down frame) + (di:no-debug-info () nil))) + +(defun nth-frame (index) + (do ((frame *sldb-stack-top* (frame-down frame)) + (i index (1- i))) + ((zerop i) frame))) + +(defimplementation compute-backtrace (start end) + (let ((end (or end most-positive-fixnum))) + (loop for f = (nth-frame start) then (frame-down f) + for i from start below end + while f collect f))) + +(defimplementation print-frame (frame stream) + (let ((*standard-output* stream)) + (handler-case + (debug::print-frame-call frame :verbosity 1 :number nil) + (error (e) + (ignore-errors (princ e stream)))))) + +(defimplementation frame-source-location (index) + (let ((frame (nth-frame index))) + (cond ((foreign-frame-p frame) (foreign-frame-source-location frame)) + ((code-location-source-location (di:frame-code-location frame)))))) + +(defimplementation eval-in-frame (form index) + (di:eval-in-frame (nth-frame index) form)) + +(defun frame-debug-vars (frame) + "Return a vector of debug-variables in frame." + (let ((loc (di:frame-code-location frame))) + (remove-if + (lambda (v) + (not (eq (di:debug-variable-validity v loc) :valid))) + (di::debug-function-debug-variables (di:frame-debug-function frame))))) + +(defun debug-var-value (var frame) + (let* ((loc (di:frame-code-location frame)) + (validity (di:debug-variable-validity var loc))) + (ecase validity + (:valid (di:debug-variable-value var frame)) + ((:invalid :unknown) (make-symbol (string validity)))))) + +(defimplementation frame-locals (index) + (let ((frame (nth-frame index))) + (loop for v across (frame-debug-vars frame) + collect (list :name (di:debug-variable-symbol v) + :id (di:debug-variable-id v) + :value (debug-var-value v frame))))) + +(defimplementation frame-var-value (frame var) + (let* ((frame (nth-frame frame)) + (dvar (aref (frame-debug-vars frame) var))) + (debug-var-value dvar frame))) + +(defimplementation frame-catch-tags (index) + (mapcar #'car (di:frame-catches (nth-frame index)))) + +(defimplementation frame-package (frame-number) + (let* ((frame (nth-frame frame-number)) + (dbg-fun (di:frame-debug-function frame))) + (typecase dbg-fun + (di::compiled-debug-function + (let* ((comp (di::compiled-debug-function-component dbg-fun)) + (dbg-info (kernel:%code-debug-info comp))) + (typecase dbg-info + (c::compiled-debug-info + (find-package (c::compiled-debug-info-package dbg-info))))))))) + +(defimplementation return-from-frame (index form) + (let ((sym (find-symbol (string 'find-debug-tag-for-frame) + :debug-internals))) + (if sym + (let* ((frame (nth-frame index)) + (probe (funcall sym frame))) + (cond (probe (throw (car probe) (eval-in-frame form index))) + (t (format nil "Cannot return from frame: ~S" frame)))) + "return-from-frame is not implemented in this version of CMUCL."))) + +(defimplementation activate-stepping (frame) + (set-step-breakpoints (nth-frame frame))) + +(defimplementation sldb-break-on-return (frame) + (break-on-return (nth-frame frame))) + +;;; We set the breakpoint in the caller which might be a bit confusing. +;;; +(defun break-on-return (frame) + (let* ((caller (di:frame-down frame)) + (cl (di:frame-code-location caller))) + (flet ((hook (frame bp) + (when (frame-pointer= frame caller) + (di:delete-breakpoint bp) + (signal-breakpoint bp frame)))) + (let* ((info (ecase (di:code-location-kind cl) + ((:single-value-return :unknown-return) nil) + (:known-return (debug-function-returns + (di:frame-debug-function frame))))) + (bp (di:make-breakpoint #'hook cl :kind :code-location + :info info))) + (di:activate-breakpoint bp) + `(:ok ,(format nil "Set breakpoint in ~A" caller)))))) + +(defun frame-pointer= (frame1 frame2) + "Return true if the frame pointers of FRAME1 and FRAME2 are the same." + (sys:sap= (di::frame-pointer frame1) (di::frame-pointer frame2))) + +;;; The PC in escaped frames at a single-return-value point is +;;; actually vm:single-value-return-byte-offset bytes after the +;;; position given in the debug info. Here we try to recognize such +;;; cases. +;;; +(defun next-code-locations (frame code-location) + "Like `debug::next-code-locations' but be careful in escaped frames." + (let ((next (debug::next-code-locations code-location))) + (flet ((adjust-pc () + (let ((cl (di::copy-compiled-code-location code-location))) + (incf (di::compiled-code-location-pc cl) + vm:single-value-return-byte-offset) + cl))) + (cond ((and (di::compiled-frame-escaped frame) + (eq (di:code-location-kind code-location) + :single-value-return) + (= (length next) 1) + (di:code-location= (car next) (adjust-pc))) + (debug::next-code-locations (car next))) + (t + next))))) + +(defun set-step-breakpoints (frame) + (let ((cl (di:frame-code-location frame))) + (when (di:debug-block-elsewhere-p (di:code-location-debug-block cl)) + (error "Cannot step in elsewhere code")) + (let* ((debug::*bad-code-location-types* + (remove :call-site debug::*bad-code-location-types*)) + (next (next-code-locations frame cl))) + (cond (next + (let ((steppoints '())) + (flet ((hook (bp-frame bp) + (signal-breakpoint bp bp-frame) + (mapc #'di:delete-breakpoint steppoints))) + (dolist (code-location next) + (let ((bp (di:make-breakpoint #'hook code-location + :kind :code-location))) + (di:activate-breakpoint bp) + (push bp steppoints)))))) + (t + (break-on-return frame)))))) + + +;; XXX the return values at return breakpoints should be passed to the +;; user hooks. debug-int.lisp should be changed to do this cleanly. + +;;; The sigcontext and the PC for a breakpoint invocation are not +;;; passed to user hook functions, but we need them to extract return +;;; values. So we advice di::handle-breakpoint and bind the values to +;;; special variables. +;;; +(defvar *breakpoint-sigcontext*) +(defvar *breakpoint-pc*) + +(define-fwrapper bind-breakpoint-sigcontext (offset c sigcontext) + (let ((*breakpoint-sigcontext* sigcontext) + (*breakpoint-pc* offset)) + (call-next-function))) +(set-fwrappers 'di::handle-breakpoint '()) +(fwrap 'di::handle-breakpoint #'bind-breakpoint-sigcontext) + +(defun sigcontext-object (sc index) + "Extract the lisp object in sigcontext SC at offset INDEX." + (kernel:make-lisp-obj (vm:sigcontext-register sc index))) + +(defun known-return-point-values (sigcontext sc-offsets) + (let ((fp (system:int-sap (vm:sigcontext-register sigcontext + vm::cfp-offset)))) + (system:without-gcing + (loop for sc-offset across sc-offsets + collect (di::sub-access-debug-var-slot fp sc-offset sigcontext))))) + +;;; CMUCL returns the first few values in registers and the rest on +;;; the stack. In the multiple value case, the number of values is +;;; stored in a dedicated register. The values of the registers can be +;;; accessed in the sigcontext for the breakpoint. There are 3 kinds +;;; of return conventions: :single-value-return, :unknown-return, and +;;; :known-return. +;;; +;;; The :single-value-return convention returns the value in a +;;; register without setting the nargs registers. +;;; +;;; The :unknown-return variant is used for multiple values. A +;;; :unknown-return point consists actually of 2 breakpoints: one for +;;; the single value case and one for the general case. The single +;;; value breakpoint comes vm:single-value-return-byte-offset after +;;; the multiple value breakpoint. +;;; +;;; The :known-return convention is used by local functions. +;;; :known-return is currently not supported because we don't know +;;; where the values are passed. +;;; +(defun breakpoint-values (breakpoint) + "Return the list of return values for a return point." + (flet ((1st (sc) (sigcontext-object sc (car vm::register-arg-offsets)))) + (let ((sc (locally (declare (optimize (speed 0))) + (alien:sap-alien *breakpoint-sigcontext* (* unix:sigcontext)))) + (cl (di:breakpoint-what breakpoint))) + (ecase (di:code-location-kind cl) + (:single-value-return + (list (1st sc))) + (:known-return + (let ((info (di:breakpoint-info breakpoint))) + (if (vectorp info) + (known-return-point-values sc info) + (progn + ;;(break) + (list "<<known-return convention not supported>>" info))))) + (:unknown-return + (let ((mv-return-pc (di::compiled-code-location-pc cl))) + (if (= mv-return-pc *breakpoint-pc*) + (mv-function-end-breakpoint-values sc) + (list (1st sc))))))))) + +;; XXX: di::get-function-end-breakpoint-values takes 2 arguments in +;; newer versions of CMUCL (after ~March 2005). +(defun mv-function-end-breakpoint-values (sigcontext) + (let ((sym (find-symbol "FUNCTION-END-BREAKPOINT-VALUES/STANDARD" :di))) + (cond (sym (funcall sym sigcontext)) + (t (funcall 'di::get-function-end-breakpoint-values sigcontext))))) + +(defun debug-function-returns (debug-fun) + "Return the return style of DEBUG-FUN." + (let* ((cdfun (di::compiled-debug-function-compiler-debug-fun debug-fun))) + (c::compiled-debug-function-returns cdfun))) + +(define-condition breakpoint (simple-condition) + ((message :initarg :message :reader breakpoint.message) + (values :initarg :values :reader breakpoint.values)) + (:report (lambda (c stream) (princ (breakpoint.message c) stream)))) + +(defimplementation condition-extras (condition) + (typecase condition + (breakpoint + ;; pop up the source buffer + `((:show-frame-source 0))) + (t '()))) + +(defun signal-breakpoint (breakpoint frame) + "Signal a breakpoint condition for BREAKPOINT in FRAME. +Try to create a informative message." + (flet ((brk (values fstring &rest args) + (let ((msg (apply #'format nil fstring args)) + (debug:*stack-top-hint* frame)) + (break 'breakpoint :message msg :values values)))) + (with-struct (di::breakpoint- kind what) breakpoint + (case kind + (:code-location + (case (di:code-location-kind what) + ((:single-value-return :known-return :unknown-return) + (let ((values (breakpoint-values breakpoint))) + (brk values "Return value: ~{~S ~}" values))) + (t + #+(or) + (when (eq (di:code-location-kind what) :call-site) + (call-site-function breakpoint frame)) + (brk nil "Breakpoint: ~S ~S" + (di:code-location-kind what) + (di::compiled-code-location-pc what))))) + (:function-start + (brk nil "Function start breakpoint")) + (t (brk nil "Breakpoint: ~A in ~A" breakpoint frame)))))) + +(defimplementation sldb-break-at-start (fname) + (let ((debug-fun (di:function-debug-function (coerce fname 'function)))) + (cond ((not debug-fun) + `(:error ,(format nil "~S has no debug-function" fname))) + (t + (flet ((hook (frame bp &optional args cookie) + (declare (ignore args cookie)) + (signal-breakpoint bp frame))) + (let ((bp (di:make-breakpoint #'hook debug-fun + :kind :function-start))) + (di:activate-breakpoint bp) + `(:ok ,(format nil "Set breakpoint in ~S" fname)))))))) + +(defun frame-cfp (frame) + "Return the Control-Stack-Frame-Pointer for FRAME." + (etypecase frame + (di::compiled-frame (di::frame-pointer frame)) + ((or di::interpreted-frame null) -1))) + +(defun frame-ip (frame) + "Return the (absolute) instruction pointer and the relative pc of FRAME." + (if (not frame) + -1 + (let ((debug-fun (di::frame-debug-function frame))) + (etypecase debug-fun + (di::compiled-debug-function + (let* ((code-loc (di:frame-code-location frame)) + (component (di::compiled-debug-function-component debug-fun)) + (pc (di::compiled-code-location-pc code-loc)) + (ip (sys:without-gcing + (sys:sap-int + (sys:sap+ (kernel:code-instructions component) pc))))) + (values ip pc))) + (di::interpreted-debug-function -1) + (di::bogus-debug-function + #-x86 + (let* ((real (di::frame-real-frame (di::frame-up frame))) + (fp (di::frame-pointer real))) + ;;#+(or) + (progn + (format *debug-io* "Frame-real-frame = ~S~%" real) + (format *debug-io* "fp = ~S~%" fp) + (format *debug-io* "lra = ~S~%" + (kernel:stack-ref fp vm::lra-save-offset))) + (values + (sys:int-sap + (- (kernel:get-lisp-obj-address + (kernel:stack-ref fp vm::lra-save-offset)) + (- (ash vm:function-code-offset vm:word-shift) + vm:function-pointer-type))) + 0)) + #+x86 + (let ((fp (di::frame-pointer (di:frame-up frame)))) + (multiple-value-bind (ra ofp) (di::x86-call-context fp) + (declare (ignore ofp)) + (values ra 0)))))))) + +(defun frame-registers (frame) + "Return the lisp registers CSP, CFP, IP, OCFP, LRA for FRAME-NUMBER." + (let* ((cfp (frame-cfp frame)) + (csp (frame-cfp (di::frame-up frame))) + (ip (frame-ip frame)) + (ocfp (frame-cfp (di::frame-down frame))) + (lra (frame-ip (di::frame-down frame)))) + (values csp cfp ip ocfp lra))) + +(defun print-frame-registers (frame-number) + (let ((frame (di::frame-real-frame (nth-frame frame-number)))) + (flet ((fixnum (p) (etypecase p + (integer p) + (sys:system-area-pointer (sys:sap-int p))))) + (apply #'format t "~ +~8X Stack Pointer +~8X Frame Pointer +~8X Instruction Pointer +~8X Saved Frame Pointer +~8X Saved Instruction Pointer~%" (mapcar #'fixnum + (multiple-value-list (frame-registers frame))))))) + +(defvar *gdb-program-name* + (ext:enumerate-search-list (p "path:gdb") + (when (probe-file p) + (return p)))) + +(defimplementation disassemble-frame (frame-number) + (print-frame-registers frame-number) + (terpri) + (let* ((frame (di::frame-real-frame (nth-frame frame-number))) + (debug-fun (di::frame-debug-function frame))) + (etypecase debug-fun + (di::compiled-debug-function + (let* ((component (di::compiled-debug-function-component debug-fun)) + (fun (di:debug-function-function debug-fun))) + (if fun + (disassemble fun) + (disassem:disassemble-code-component component)))) + (di::bogus-debug-function + (cond ((probe-file *gdb-program-name*) + (let ((ip (sys:sap-int (frame-ip frame)))) + (princ (gdb-command "disas 0x~x" ip)))) + (t + (format t "~%[Disassembling bogus frames not implemented]"))))))) + +(defmacro with-temporary-file ((stream filename) &body body) + `(call/temporary-file (lambda (,stream ,filename) . ,body))) + +(defun call/temporary-file (fun) + (let ((name (system::pick-temporary-file-name))) + (unwind-protect + (with-open-file (stream name :direction :output :if-exists :supersede) + (funcall fun stream name)) + (delete-file name)))) + +(defun gdb-command (format-string &rest args) + (let ((str (gdb-exec (format nil + "interpreter-exec mi2 \"attach ~d\"~%~ + interpreter-exec console ~s~%detach" + (getpid) + (apply #'format nil format-string args)))) + (prompt (format nil + #-(and darwin x86) "~%^done~%(gdb) ~%" + #+(and darwin x86) +"~%^done,thread-id=\"1\"~%(gdb) ~%"))) + (subseq str (+ (or (search prompt str) 0) (length prompt))))) + +(defun gdb-exec (cmd) + (with-temporary-file (file filename) + (write-string cmd file) + (force-output file) + (let* ((output (make-string-output-stream)) + ;; gdb on sparc needs to know the executable to find the + ;; symbols. Without this, gdb can't disassemble anything. + ;; NOTE: We assume that the first entry in + ;; lisp::*cmucl-lib* is the bin directory where lisp is + ;; located. If this is not true, we'll have to do + ;; something better to find the lisp executable. + (lisp-path + #+sparc + (list + (namestring + (probe-file + (merge-pathnames "lisp" (car (lisp::parse-unix-search-path + lisp::*cmucl-lib*)))))) + #-sparc + nil) + (proc (ext:run-program *gdb-program-name* + `(,@lisp-path "-batch" "-x" ,filename) + :wait t + :output output))) + (assert (eq (ext:process-status proc) :exited)) + (assert (eq (ext:process-exit-code proc) 0)) + (get-output-stream-string output)))) + +(defun foreign-frame-p (frame) + #-x86 + (let ((ip (frame-ip frame))) + (and (sys:system-area-pointer-p ip) + (typep (di::frame-debug-function frame) 'di::bogus-debug-function))) + #+x86 + (let ((ip (frame-ip frame))) + (and (sys:system-area-pointer-p ip) + (multiple-value-bind (pc code) + (di::compute-lra-data-from-pc ip) + (declare (ignore pc)) + (not code))))) + +(defun foreign-frame-source-location (frame) + (let ((ip (sys:sap-int (frame-ip frame)))) + (cond ((probe-file *gdb-program-name*) + (parse-gdb-line-info (gdb-command "info line *0x~x" ip))) + (t `(:error "no srcloc available for ~a" frame))))) + +;; The output of gdb looks like: +;; Line 215 of "../../src/lisp/x86-assem.S" +;; starts at address 0x805318c <Ldone+11> +;; and ends at 0x805318e <Ldone+13>. +;; The ../../ are fixed up with the "target:" search list which might +;; be wrong sometimes. +(defun parse-gdb-line-info (string) + (with-input-from-string (*standard-input* string) + (let ((w1 (read-word))) + (cond ((equal w1 "Line") + (let ((line (read-word))) + (assert (equal (read-word) "of")) + (let* ((file (read-from-string (read-word))) + (pathname + (or (probe-file file) + (probe-file (format nil "target:lisp/~a" file)) + file))) + (make-location (list :file (unix-truename pathname)) + (list :line (parse-integer line)))))) + (t + `(:error ,string)))))) + +(defun read-word (&optional (stream *standard-input*)) + (peek-char t stream) + (concatenate 'string (loop until (whitespacep (peek-char nil stream)) + collect (read-char stream)))) + +(defun whitespacep (char) + (member char '(#\space #\newline))) + + +;;;; Inspecting + +(defconstant +lowtag-symbols+ + '(vm:even-fixnum-type + vm:function-pointer-type + vm:other-immediate-0-type + vm:list-pointer-type + vm:odd-fixnum-type + vm:instance-pointer-type + vm:other-immediate-1-type + vm:other-pointer-type) + "Names of the constants that specify type tags. +The `symbol-value' of each element is a type tag.") + +(defconstant +header-type-symbols+ + (labels ((suffixp (suffix string) + (and (>= (length string) (length suffix)) + (string= string suffix :start1 (- (length string) + (length suffix))))) + (header-type-symbol-p (x) + (and (suffixp "-TYPE" (symbol-name x)) + (not (member x +lowtag-symbols+)) + (boundp x) + (typep (symbol-value x) 'fixnum)))) + (remove-if-not #'header-type-symbol-p + (append (apropos-list "-TYPE" "VM") + (apropos-list "-TYPE" "BIGNUM")))) + "A list of names of the type codes in boxed objects.") + +(defimplementation describe-primitive-type (object) + (with-output-to-string (*standard-output*) + (let* ((lowtag (kernel:get-lowtag object)) + (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value))) + (format t "lowtag: ~A" lowtag-symbol) + (when (member lowtag (list vm:other-pointer-type + vm:function-pointer-type + vm:other-immediate-0-type + vm:other-immediate-1-type + )) + (let* ((type (kernel:get-type object)) + (type-symbol (find type +header-type-symbols+ + :key #'symbol-value))) + (format t ", type: ~A" type-symbol)))))) + +(defmethod emacs-inspect ((o t)) + (cond ((di::indirect-value-cell-p o) + `("Value: " (:value ,(c:value-cell-ref o)))) + ((alien::alien-value-p o) + (inspect-alien-value o)) + (t + (cmucl-inspect o)))) + +(defun cmucl-inspect (o) + (destructuring-bind (text labeledp . parts) (inspect::describe-parts o) + (list* (format nil "~A~%" text) + (if labeledp + (loop for (label . value) in parts + append (label-value-line label value)) + (loop for value in parts for i from 0 + append (label-value-line i value)))))) + +(defmethod emacs-inspect ((o function)) + (let ((header (kernel:get-type o))) + (cond ((= header vm:function-header-type) + (append (label-value-line* + ("Self" (kernel:%function-self o)) + ("Next" (kernel:%function-next o)) + ("Name" (kernel:%function-name o)) + ("Arglist" (kernel:%function-arglist o)) + ("Type" (kernel:%function-type o)) + ("Code" (kernel:function-code-header o))) + (list + (with-output-to-string (s) + (disassem:disassemble-function o :stream s))))) + ((= header vm:closure-header-type) + (list* (format nil "~A is a closure.~%" o) + (append + (label-value-line "Function" (kernel:%closure-function o)) + `("Environment:" (:newline)) + (loop for i from 0 below (1- (kernel:get-closure-length o)) + append (label-value-line + i (kernel:%closure-index-ref o i)))))) + ((eval::interpreted-function-p o) + (cmucl-inspect o)) + (t + (call-next-method))))) + +(defmethod emacs-inspect ((o kernel:funcallable-instance)) + (append (label-value-line* + (:function (kernel:%funcallable-instance-function o)) + (:lexenv (kernel:%funcallable-instance-lexenv o)) + (:layout (kernel:%funcallable-instance-layout o))) + (cmucl-inspect o))) + +(defmethod emacs-inspect ((o kernel:code-component)) + (append + (label-value-line* + ("code-size" (kernel:%code-code-size o)) + ("entry-points" (kernel:%code-entry-points o)) + ("debug-info" (kernel:%code-debug-info o)) + ("trace-table-offset" (kernel:code-header-ref + o vm:code-trace-table-offset-slot))) + `("Constants:" (:newline)) + (loop for i from vm:code-constants-offset + below (kernel:get-header-data o) + append (label-value-line i (kernel:code-header-ref o i))) + `("Code:" + (:newline) + , (with-output-to-string (*standard-output*) + (cond ((c::compiled-debug-info-p (kernel:%code-debug-info o)) + (disassem:disassemble-code-component o)) + ((or + (c::debug-info-p (kernel:%code-debug-info o)) + (consp (kernel:code-header-ref + o vm:code-trace-table-offset-slot))) + (c:disassem-byte-component o)) + (t + (disassem:disassemble-memory + (disassem::align + (+ (logandc2 (kernel:get-lisp-obj-address o) + vm:lowtag-mask) + (* vm:code-constants-offset vm:word-bytes)) + (ash 1 vm:lowtag-bits)) + (ash (kernel:%code-code-size o) vm:word-shift)))))))) + +(defmethod emacs-inspect ((o kernel:fdefn)) + (label-value-line* + ("name" (kernel:fdefn-name o)) + ("function" (kernel:fdefn-function o)) + ("raw-addr" (sys:sap-ref-32 + (sys:int-sap (kernel:get-lisp-obj-address o)) + (* vm:fdefn-raw-addr-slot vm:word-bytes))))) + +#+(or) +(defmethod emacs-inspect ((o array)) + (if (typep o 'simple-array) + (call-next-method) + (label-value-line* + (:header (describe-primitive-type o)) + (:rank (array-rank o)) + (:fill-pointer (kernel:%array-fill-pointer o)) + (:fill-pointer-p (kernel:%array-fill-pointer-p o)) + (:elements (kernel:%array-available-elements o)) + (:data (kernel:%array-data-vector o)) + (:displacement (kernel:%array-displacement o)) + (:displaced-p (kernel:%array-displaced-p o)) + (:dimensions (array-dimensions o))))) + +(defmethod emacs-inspect ((o simple-vector)) + (append + (label-value-line* + (:header (describe-primitive-type o)) + (:length (c::vector-length o))) + (loop for i below (length o) + append (label-value-line i (aref o i))))) + +(defun inspect-alien-record (alien) + (with-struct (alien::alien-value- sap type) alien + (with-struct (alien::alien-record-type- kind name fields) type + (append + (label-value-line* + (:sap sap) + (:kind kind) + (:name name)) + (loop for field in fields + append (let ((slot (alien::alien-record-field-name field))) + (declare (optimize (speed 0))) + (label-value-line slot (alien:slot alien slot)))))))) + +(defun inspect-alien-pointer (alien) + (with-struct (alien::alien-value- sap type) alien + (label-value-line* + (:sap sap) + (:type type) + (:to (alien::deref alien))))) + +(defun inspect-alien-value (alien) + (typecase (alien::alien-value-type alien) + (alien::alien-record-type (inspect-alien-record alien)) + (alien::alien-pointer-type (inspect-alien-pointer alien)) + (t (cmucl-inspect alien)))) + +(defimplementation eval-context (obj) + (cond ((typep (class-of obj) 'structure-class) + (let* ((dd (kernel:layout-info (kernel:layout-of obj))) + (slots (kernel:dd-slots dd))) + (list* (cons '*package* + (symbol-package (if slots + (kernel:dsd-name (car slots)) + (kernel:dd-name dd)))) + (loop for slot in slots collect + (cons (kernel:dsd-name slot) + (funcall (kernel:dsd-accessor slot) obj)))))))) + + +;;;; Profiling +(defimplementation profile (fname) + (eval `(profile:profile ,fname))) + +(defimplementation unprofile (fname) + (eval `(profile:unprofile ,fname))) + +(defimplementation unprofile-all () + (eval `(profile:unprofile)) + "All functions unprofiled.") + +(defimplementation profile-report () + (eval `(profile:report-time))) + +(defimplementation profile-reset () + (eval `(profile:reset-time)) + "Reset profiling counters.") + +(defimplementation profiled-functions () + profile:*timed-functions*) + +(defimplementation profile-package (package callers methods) + (profile:profile-all :package package + :callers-p callers + :methods methods)) + + +;;;; Multiprocessing + +#+mp +(progn + (defimplementation initialize-multiprocessing (continuation) + (mp::init-multi-processing) + (mp:make-process continuation :name "swank") + ;; Threads magic: this never returns! But top-level becomes + ;; available again. + (unless mp::*idle-process* + (mp::startup-idle-and-top-level-loops))) + + (defimplementation spawn (fn &key name) + (mp:make-process fn :name (or name "Anonymous"))) + + (defvar *thread-id-counter* 0) + + (defimplementation thread-id (thread) + (or (getf (mp:process-property-list thread) 'id) + (setf (getf (mp:process-property-list thread) 'id) + (incf *thread-id-counter*)))) + + (defimplementation find-thread (id) + (find id (all-threads) + :key (lambda (p) (getf (mp:process-property-list p) 'id)))) + + (defimplementation thread-name (thread) + (mp:process-name thread)) + + (defimplementation thread-status (thread) + (mp:process-whostate thread)) + + (defimplementation current-thread () + mp:*current-process*) + + (defimplementation all-threads () + (copy-list mp:*all-processes*)) + + (defimplementation interrupt-thread (thread fn) + (mp:process-interrupt thread fn)) + + (defimplementation kill-thread (thread) + (mp:destroy-process thread)) + + (defvar *mailbox-lock* (mp:make-lock "mailbox lock")) + + (defstruct (mailbox (:conc-name mailbox.)) + (mutex (mp:make-lock "process mailbox")) + (queue '() :type list)) + + (defun mailbox (thread) + "Return THREAD's mailbox." + (mp:with-lock-held (*mailbox-lock*) + (or (getf (mp:process-property-list thread) 'mailbox) + (setf (getf (mp:process-property-list thread) 'mailbox) + (make-mailbox))))) + + (defimplementation send (thread message) + (check-slime-interrupts) + (let* ((mbox (mailbox thread))) + (mp:with-lock-held ((mailbox.mutex mbox)) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message)))))) + + (defimplementation receive-if (test &optional timeout) + (let ((mbox (mailbox mp:*current-process*))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (mp:with-lock-held ((mailbox.mutex mbox)) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) + (nconc (ldiff q tail) (cdr tail))) + (return (car tail))))) + (when (eq timeout t) (return (values nil t))) + (mp:process-wait-with-timeout + "receive-if" 0.5 + (lambda () (some test (mailbox.queue mbox))))))) + + + ) ;; #+mp + + + +;;;; GC hooks +;;; +;;; Display GC messages in the echo area to avoid cluttering the +;;; normal output. +;;; + +;; this should probably not be here, but where else? +(defun background-message (message) + (swank::background-message message)) + +(defun print-bytes (nbytes &optional stream) + "Print the number NBYTES to STREAM in KB, MB, or GB units." + (let ((names '((0 bytes) (10 kb) (20 mb) (30 gb) (40 tb) (50 eb)))) + (multiple-value-bind (power name) + (loop for ((p1 n1) (p2 n2)) on names + while n2 do + (when (<= (expt 2 p1) nbytes (1- (expt 2 p2))) + (return (values p1 n1)))) + (cond (name + (format stream "~,1F ~A" (/ nbytes (expt 2 power)) name)) + (t + (format stream "~:D bytes" nbytes)))))) + +(defconstant gc-generations 6) + +#+gencgc +(defun generation-stats () + "Return a string describing the size distribution among the generations." + (let* ((alloc (loop for i below gc-generations + collect (lisp::gencgc-stats i))) + (sum (coerce (reduce #'+ alloc) 'float))) + (format nil "~{~3F~^/~}" + (mapcar (lambda (size) (/ size sum)) + alloc)))) + +(defvar *gc-start-time* 0) + +(defun pre-gc-hook (bytes-in-use) + (setq *gc-start-time* (get-internal-real-time)) + (let ((msg (format nil "[Commencing GC with ~A in use.]" + (print-bytes bytes-in-use)))) + (background-message msg))) + +(defun post-gc-hook (bytes-retained bytes-freed trigger) + (declare (ignore trigger)) + (let* ((seconds (/ (- (get-internal-real-time) *gc-start-time*) + internal-time-units-per-second)) + (msg (format nil "[GC done. ~A freed ~A retained ~A ~4F sec]" + (print-bytes bytes-freed) + (print-bytes bytes-retained) + #+gencgc(generation-stats) + #-gencgc"" + seconds))) + (background-message msg))) + +(defun install-gc-hooks () + (setq ext:*gc-notify-before* #'pre-gc-hook) + (setq ext:*gc-notify-after* #'post-gc-hook)) + +(defun remove-gc-hooks () + (setq ext:*gc-notify-before* #'lisp::default-gc-notify-before) + (setq ext:*gc-notify-after* #'lisp::default-gc-notify-after)) + +(defvar *install-gc-hooks* t + "If non-nil install GC hooks") + +(defimplementation emacs-connected () + (when *install-gc-hooks* + (install-gc-hooks))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;Trace implementations +;;In CMUCL, we have: +;; (trace <name>) +;; (trace (method <name> <qualifier>? (<specializer>+))) +;; (trace :methods t '<name>) ;;to trace all methods of the gf <name> +;; <name> can be a normal name or a (setf name) + +(defun tracedp (spec) + (member spec (eval '(trace)) :test #'equal)) + +(defun toggle-trace-aux (spec &rest options) + (cond ((tracedp spec) + (eval `(untrace ,spec)) + (format nil "~S is now untraced." spec)) + (t + (eval `(trace ,spec ,@options)) + (format nil "~S is now traced." spec)))) + +(defimplementation toggle-trace (spec) + (ecase (car spec) + ((setf) + (toggle-trace-aux spec)) + ((:defgeneric) + (let ((name (second spec))) + (toggle-trace-aux name :methods name))) + ((:defmethod) + (cond ((fboundp `(method ,@(cdr spec))) + (toggle-trace-aux `(method ,(cdr spec)))) + ;; Man, is this ugly + ((fboundp `(pcl::fast-method ,@(cdr spec))) + (toggle-trace-aux `(pcl::fast-method ,@(cdr spec)))) + (t + (error 'undefined-function :name (cdr spec))))) + ((:call) + (destructuring-bind (caller callee) (cdr spec) + (toggle-trace-aux (process-fspec callee) + :wherein (list (process-fspec caller))))) + ;; doesn't work properly + ;; ((:labels :flet) (toggle-trace-aux (process-fspec spec))) + )) + +(defun process-fspec (fspec) + (cond ((consp fspec) + (ecase (first fspec) + ((:defun :defgeneric) (second fspec)) + ((:defmethod) + `(method ,(second fspec) ,@(third fspec) ,(fourth fspec))) + ((:labels) `(labels ,(third fspec) ,(process-fspec (second fspec)))) + ((:flet) `(flet ,(third fspec) ,(process-fspec (second fspec)))))) + (t + fspec))) + +;;; Weak datastructures + +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak-p t args)) + + +;;; Save image + +(defimplementation save-image (filename &optional restart-function) + (multiple-value-bind (pid error) (unix:unix-fork) + (when (not pid) (error "fork: ~A" (unix:get-unix-error-msg error))) + (cond ((= pid 0) + (apply #'ext:save-lisp + filename + (if restart-function + `(:init-function ,restart-function)))) + (t + (let ((status (waitpid pid))) + (destructuring-bind (&key exited? status &allow-other-keys) status + (assert (and exited? (equal status 0)) () + "Invalid exit status: ~a" status))))))) + +(defun waitpid (pid) + (alien:with-alien ((status c-call:int)) + (let ((code (alien:alien-funcall + (alien:extern-alien + waitpid (alien:function c-call:int c-call:int + (* c-call:int) c-call:int)) + pid (alien:addr status) 0))) + (cond ((= code -1) (error "waitpid: ~A" (unix:get-unix-error-msg))) + (t (assert (= code pid)) + (decode-wait-status status)))))) + +(defun decode-wait-status (status) + (let ((output (with-output-to-string (s) + (call-program (list (process-status-program) + (format nil "~d" status)) + :output s)))) + (read-from-string output))) + +(defun call-program (args &key output) + (destructuring-bind (program &rest args) args + (let ((process (ext:run-program program args :output output))) + (when (not program) (error "fork failed")) + (unless (and (eq (ext:process-status process) :exited) + (= (ext:process-exit-code process) 0)) + (error "Non-zero exit status"))))) + +(defvar *process-status-program* nil) + +(defun process-status-program () + (or *process-status-program* + (setq *process-status-program* + (compile-process-status-program)))) + +(defun compile-process-status-program () + (let ((infile (system::pick-temporary-file-name + "/tmp/process-status~d~c.c"))) + (with-open-file (stream infile :direction :output :if-exists :supersede) + (format stream " +#include <stdio.h> +#include <stdlib.h> +#include <sys/types.h> +#include <sys/wait.h> +#include <assert.h> + +#define FLAG(value) (value ? \"t\" : \"nil\") + +int main (int argc, char** argv) { + assert (argc == 2); + { + char* endptr = NULL; + char* arg = argv[1]; + long int status = strtol (arg, &endptr, 10); + assert (endptr != arg && *endptr == '\\0'); + printf (\"(:exited? %s :status %d :signal? %s :signal %d :coredump? %s\" + \" :stopped? %s :stopsig %d)\\n\", + FLAG(WIFEXITED(status)), WEXITSTATUS(status), + FLAG(WIFSIGNALED(status)), WTERMSIG(status), + FLAG(WCOREDUMP(status)), + FLAG(WIFSTOPPED(status)), WSTOPSIG(status)); + fflush (NULL); + return 0; + } +} +") + (finish-output stream)) + (let* ((outfile (system::pick-temporary-file-name)) + (args (list "cc" "-o" outfile infile))) + (warn "Running cc: ~{~a ~}~%" args) + (call-program args :output t) + (delete-file infile) + outfile))) + +;; FIXME: lisp:unicode-complete introduced in version 20d. +#+#.(swank/backend:with-symbol 'unicode-complete 'lisp) +(defun match-semi-standard (prefix matchp) + ;; Handle the CMUCL's short character names. + (loop for name in lisp::char-name-alist + when (funcall matchp prefix (car name)) + collect (car name))) + +#+#.(swank/backend:with-symbol 'unicode-complete 'lisp) +(defimplementation character-completion-set (prefix matchp) + (let ((names (lisp::unicode-complete prefix))) + ;; Match prefix against semistandard names. If there's a match, + ;; add it to our list of matches. + (let ((semi-standard (match-semi-standard prefix matchp))) + (when semi-standard + (setf names (append semi-standard names)))) + (setf names (mapcar #'string-capitalize names)) + (loop for n in names + when (funcall matchp prefix n) + collect n))) diff --git a/vim/bundle/slimv/slime/swank/corman.lisp b/vim/bundle/slimv/slime/swank/corman.lisp new file mode 100644 index 0000000..80d9ddd --- /dev/null +++ b/vim/bundle/slimv/slime/swank/corman.lisp @@ -0,0 +1,583 @@ +;;; +;;; swank-corman.lisp --- Corman Lisp specific code for SLIME. +;;; +;;; Copyright (C) 2004, 2005 Espen Wiborg (espenhw@grumblesmurf.org) +;;; +;;; License +;;; ======= +;;; This software is provided 'as-is', without any express or implied +;;; warranty. In no event will the author be held liable for any damages +;;; arising from the use of this software. +;;; +;;; Permission is granted to anyone to use this software for any purpose, +;;; including commercial applications, and to alter it and redistribute +;;; it freely, subject to the following restrictions: +;;; +;;; 1. The origin of this software must not be misrepresented; you must +;;; not claim that you wrote the original software. If you use this +;;; software in a product, an acknowledgment in the product documentation +;;; would be appreciated but is not required. +;;; +;;; 2. Altered source versions must be plainly marked as such, and must +;;; not be misrepresented as being the original software. +;;; +;;; 3. This notice may not be removed or altered from any source +;;; distribution. +;;; +;;; Notes +;;; ===== +;;; You will need CCL 2.51, and you will *definitely* need to patch +;;; CCL with the patches at +;;; http://www.grumblesmurf.org/lisp/corman-patches, otherwise SLIME +;;; will blow up in your face. You should also follow the +;;; instructions on http://www.grumblesmurf.org/lisp/corman-slime. +;;; +;;; The only communication style currently supported is NIL. +;;; +;;; Starting CCL inside emacs (with M-x slime) seems to work for me +;;; with Corman Lisp 2.51, but I have seen random failures with 2.5 +;;; (sometimes it works, other times it hangs on start or hangs when +;;; initializing WinSock) - starting CCL externally and using M-x +;;; slime-connect always works fine. +;;; +;;; Sometimes CCL gets confused and starts giving you random memory +;;; access violation errors on startup; if this happens, try redumping +;;; your image. +;;; +;;; What works +;;; ========== +;;; * Basic editing and evaluation +;;; * Arglist display +;;; * Compilation +;;; * Loading files +;;; * apropos/describe +;;; * Debugger +;;; * Inspector +;;; +;;; TODO +;;; ==== +;;; * More debugger functionality (missing bits: restart-frame, +;;; return-from-frame, disassemble-frame, activate-stepping, +;;; toggle-trace) +;;; * XREF +;;; * Profiling +;;; * More sophisticated communication styles than NIL +;;; + +(in-package :swank/backend) + +;;; Pull in various needed bits +(require :composite-streams) +(require :sockets) +(require :winbase) +(require :lp) + +(use-package :gs) + +;; MOP stuff + +(defclass swank-mop:standard-slot-definition () + () + (:documentation + "Dummy class created so that swank.lisp will compile and load.")) + +(defun named-by-gensym-p (c) + (null (symbol-package (class-name c)))) + +(deftype swank-mop:eql-specializer () + '(satisfies named-by-gensym-p)) + +(defun swank-mop:eql-specializer-object (specializer) + (with-hash-table-iterator (next-entry cl::*clos-singleton-specializers*) + (loop (multiple-value-bind (more key value) + (next-entry) + (unless more (return nil)) + (when (eq specializer value) + (return key)))))) + +(defun swank-mop:class-finalized-p (class) + (declare (ignore class)) + t) + +(defun swank-mop:class-prototype (class) + (make-instance class)) + +(defun swank-mop:specializer-direct-methods (obj) + (declare (ignore obj)) + nil) + +(defun swank-mop:generic-function-argument-precedence-order (gf) + (generic-function-lambda-list gf)) + +(defun swank-mop:generic-function-method-combination (gf) + (declare (ignore gf)) + :standard) + +(defun swank-mop:generic-function-declarations (gf) + (declare (ignore gf)) + nil) + +(defun swank-mop:slot-definition-documentation (slot) + (declare (ignore slot)) + (getf slot :documentation nil)) + +(defun swank-mop:slot-definition-type (slot) + (declare (ignore slot)) + t) + +(import-swank-mop-symbols :cl '(;; classes + :standard-slot-definition + :eql-specializer + :eql-specializer-object + ;; standard class readers + :class-default-initargs + :class-direct-default-initargs + :class-finalized-p + :class-prototype + :specializer-direct-methods + ;; gf readers + :generic-function-argument-precedence-order + :generic-function-declarations + :generic-function-method-combination + ;; method readers + ;; slot readers + :slot-definition-documentation + :slot-definition-type)) + +;;;; swank implementations + +;;; Debugger + +(defvar *stack-trace* nil) +(defvar *frame-trace* nil) + +(defstruct frame + name function address debug-info variables) + +(defimplementation call-with-debugging-environment (fn) + (let* ((real-stack-trace (cl::stack-trace)) + (*stack-trace* (cdr (member 'cl:invoke-debugger real-stack-trace + :key #'car))) + (*frame-trace* + (let* ((db::*debug-level* (1+ db::*debug-level*)) + (db::*debug-frame-pointer* (db::stash-ebp + (ct:create-foreign-ptr))) + (db::*debug-max-level* (length real-stack-trace)) + (db::*debug-min-level* 1)) + (cdr (member #'cl:invoke-debugger + (cons + (make-frame :function nil) + (loop for i from db::*debug-min-level* + upto db::*debug-max-level* + until (eq (db::get-frame-function i) + cl::*top-level*) + collect + (make-frame + :function (db::get-frame-function i) + :address (db::get-frame-address i)))) + :key #'frame-function))))) + (funcall fn))) + +(defimplementation compute-backtrace (start end) + (loop for f in (subseq *stack-trace* start (min end (length *stack-trace*))) + collect f)) + +(defimplementation print-frame (frame stream) + (format stream "~S" frame)) + +(defun get-frame-debug-info (frame) + (or (frame-debug-info frame) + (setf (frame-debug-info frame) + (db::prepare-frame-debug-info (frame-function frame) + (frame-address frame))))) + +(defimplementation frame-locals (frame-number) + (let* ((frame (elt *frame-trace* frame-number)) + (info (get-frame-debug-info frame))) + (let ((var-list + (loop for i from 4 below (length info) by 2 + collect `(list :name ',(svref info i) :id 0 + :value (db::debug-filter ,(svref info i)))))) + (let ((vars (eval-in-frame `(list ,@var-list) frame-number))) + (setf (frame-variables frame) vars))))) + +(defimplementation eval-in-frame (form frame-number) + (let ((frame (elt *frame-trace* frame-number))) + (let ((cl::*compiler-environment* (get-frame-debug-info frame))) + (eval form)))) + +(defimplementation frame-var-value (frame-number var) + (let ((vars (frame-variables (elt *frame-trace* frame-number)))) + (when vars + (second (elt vars var))))) + +(defimplementation frame-source-location (frame-number) + (fspec-location (frame-function (elt *frame-trace* frame-number)))) + +(defun break (&optional (format-control "Break") &rest format-arguments) + (with-simple-restart (continue "Return from BREAK.") + (let ();(*debugger-hook* nil)) + (let ((condition + (make-condition 'simple-condition + :format-control format-control + :format-arguments format-arguments))) + ;;(format *debug-io* ";;; User break: ~A~%" condition) + (invoke-debugger condition)))) + nil) + +;;; Socket communication + +(defimplementation create-socket (host port &key backlog) + (sockets:start-sockets) + (sockets:make-server-socket :host host :port port)) + +(defimplementation local-port (socket) + (sockets:socket-port socket)) + +(defimplementation close-socket (socket) + (close socket)) + +(defimplementation accept-connection (socket + &key external-format buffering timeout) + (declare (ignore buffering timeout external-format)) + (sockets:make-socket-stream (sockets:accept-socket socket))) + +;;; Misc + +(defimplementation preferred-communication-style () + nil) + +(defimplementation getpid () + ccl:*current-process-id*) + +(defimplementation lisp-implementation-type-name () + "cormanlisp") + +(defimplementation quit-lisp () + (sockets:stop-sockets) + (win32:exitprocess 0)) + +(defimplementation set-default-directory (directory) + (setf (ccl:current-directory) directory) + (directory-namestring (setf *default-pathname-defaults* + (truename (merge-pathnames directory))))) + +(defimplementation default-directory () + (directory-namestring (ccl:current-directory))) + +(defimplementation macroexpand-all (form &optional env) + (declare (ignore env)) + (ccl:macroexpand-all form)) + +;;; Documentation + +(defun fspec-location (fspec) + (when (symbolp fspec) + (setq fspec (symbol-function fspec))) + (let ((file (ccl::function-source-file fspec))) + (if file + (handler-case + (let ((truename (truename + (merge-pathnames file + ccl:*cormanlisp-directory*)))) + (make-location (list :file (namestring truename)) + (if (ccl::function-source-line fspec) + (list :line + (1+ (ccl::function-source-line fspec))) + (list :function-name + (princ-to-string + (function-name fspec)))))) + (error (c) (list :error (princ-to-string c)))) + (list :error (format nil "No source information available for ~S" + fspec))))) + +(defimplementation find-definitions (name) + (list (list name (fspec-location name)))) + +(defimplementation arglist (name) + (handler-case + (cond ((and (symbolp name) + (macro-function name)) + (ccl::macro-lambda-list (symbol-function name))) + (t + (when (symbolp name) + (setq name (symbol-function name))) + (if (eq (class-of name) cl::the-class-standard-gf) + (generic-function-lambda-list name) + (ccl:function-lambda-list name)))) + (error () :not-available))) + +(defimplementation function-name (fn) + (handler-case (getf (cl::function-info-list fn) 'cl::function-name) + (error () nil))) + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind &optional (sym symbol)) + (or (documentation sym kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (when (boundp symbol) + (doc 'variable))) + (maybe-push + :function (if (fboundp symbol) + (doc 'function))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + result))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + (:variable + (describe symbol)) + ((:function :generic-function) + (describe (symbol-function symbol))) + (:class + (describe (find-class symbol))))) + +;;; Compiler + +(defvar *buffer-name* nil) +(defvar *buffer-position*) +(defvar *buffer-string*) +(defvar *compile-filename* nil) + +;; FIXME +(defimplementation call-with-compilation-hooks (FN) + (handler-bind ((error (lambda (c) + (signal 'compiler-condition + :original-condition c + :severity :warning + :message (format nil "~A" c) + :location + (cond (*buffer-name* + (make-location + (list :buffer *buffer-name*) + (list :offset *buffer-position* 0))) + (*compile-filename* + (make-location + (list :file *compile-filename*) + (list :position 1))) + (t + (list :error "No location"))))))) + (funcall fn))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore external-format policy)) + (with-compilation-hooks () + (let ((*buffer-name* nil) + (*compile-filename* input-file)) + (multiple-value-bind (output-file warnings? failure?) + (compile-file input-file :output-file output-file) + (values output-file warnings? + (or failure? (and load-p (load output-file)))))))) + +(defimplementation swank-compile-string (string &key buffer position filename + policy) + (declare (ignore filename policy)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-position* position) + (*buffer-string* string)) + (funcall (compile nil (read-from-string + (format nil "(~S () ~A)" 'lambda string)))) + t))) + +;;;; Inspecting + +;; Hack to make swank.lisp load, at least +(defclass file-stream ()) + +(defun comma-separated (list &optional (callback (lambda (v) + `(:value ,v)))) + (butlast (loop for e in list + collect (funcall callback e) + collect ", "))) + +(defmethod emacs-inspect ((class standard-class)) + `("Name: " + (:value ,(class-name class)) + (:newline) + "Super classes: " + ,@(comma-separated (swank-mop:class-direct-superclasses class)) + (:newline) + "Direct Slots: " + ,@(comma-separated + (swank-mop:class-direct-slots class) + (lambda (slot) + `(:value ,slot + ,(princ-to-string + (swank-mop:slot-definition-name slot))))) + (:newline) + "Effective Slots: " + ,@(if (swank-mop:class-finalized-p class) + (comma-separated + (swank-mop:class-slots class) + (lambda (slot) + `(:value ,slot ,(princ-to-string + (swank-mop:slot-definition-name slot))))) + '("#<N/A (class not finalized)>")) + (:newline) + ,@(when (documentation class t) + `("Documentation:" (:newline) ,(documentation class t) (:newline))) + "Sub classes: " + ,@(comma-separated (swank-mop:class-direct-subclasses class) + (lambda (sub) + `(:value ,sub ,(princ-to-string (class-name sub))))) + (:newline) + "Precedence List: " + ,@(if (swank-mop:class-finalized-p class) + (comma-separated + (swank-mop:class-precedence-list class) + (lambda (class) + `(:value ,class + ,(princ-to-string (class-name class))))) + '("#<N/A (class not finalized)>")) + (:newline))) + +(defmethod emacs-inspect ((slot cons)) + ;; Inspects slot definitions + (if (eq (car slot) :name) + `("Name: " (:value ,(swank-mop:slot-definition-name slot)) + (:newline) + ,@(when (swank-mop:slot-definition-documentation slot) + `("Documentation:" + (:newline) + (:value + ,(swank-mop:slot-definition-documentation slot)) + (:newline))) + "Init args: " (:value + ,(swank-mop:slot-definition-initargs slot)) + (:newline) + "Init form: " + ,(if (swank-mop:slot-definition-initfunction slot) + `(:value ,(swank-mop:slot-definition-initform slot)) + "#<unspecified>") (:newline) + "Init function: " + (:value ,(swank-mop:slot-definition-initfunction slot)) + (:newline)) + (call-next-method))) + +(defmethod emacs-inspect ((pathname pathnames::pathname-internal)) + (list* (if (wild-pathname-p pathname) + "A wild pathname." + "A pathname.") + '(:newline) + (append (label-value-line* + ("Namestring" (namestring pathname)) + ("Host" (pathname-host pathname)) + ("Device" (pathname-device pathname)) + ("Directory" (pathname-directory pathname)) + ("Name" (pathname-name pathname)) + ("Type" (pathname-type pathname)) + ("Version" (pathname-version pathname))) + (unless (or (wild-pathname-p pathname) + (not (probe-file pathname))) + (label-value-line "Truename" (truename pathname)))))) + +(defmethod emacs-inspect ((o t)) + (cond ((cl::structurep o) (inspect-structure o)) + (t (call-next-method)))) + +(defun inspect-structure (o) + (let* ((template (cl::uref o 1)) + (num-slots (cl::struct-template-num-slots template))) + (cond ((symbolp template) + (loop for i below num-slots + append (label-value-line i (cl::uref o (+ 2 i))))) + (t + (loop for i below num-slots + append (label-value-line (elt template (+ 6 (* i 5))) + (cl::uref o (+ 2 i)))))))) + + +;;; Threads + +(require 'threads) + +(defstruct (mailbox (:conc-name mailbox.)) + thread + (lock (make-instance 'threads:critical-section)) + (queue '() :type list)) + +(defvar *mailbox-lock* (make-instance 'threads:critical-section)) +(defvar *mailboxes* (list)) + +(defmacro with-lock (lock &body body) + `(threads:with-synchronization (threads:cs ,lock) + ,@body)) + +(defimplementation spawn (fun &key name) + (declare (ignore name)) + (th:create-thread + (lambda () + (handler-bind ((serious-condition #'invoke-debugger)) + (unwind-protect (funcall fun) + (with-lock *mailbox-lock* + (setq *mailboxes* (remove cormanlisp:*current-thread-id* + *mailboxes* :key #'mailbox.thread)))))))) + +(defimplementation thread-id (thread) + thread) + +(defimplementation find-thread (thread) + (if (thread-alive-p thread) + thread)) + +(defimplementation thread-alive-p (thread) + (if (threads:thread-handle thread) t nil)) + +(defimplementation current-thread () + cormanlisp:*current-thread-id*) + +;; XXX implement it +(defimplementation all-threads () + '()) + +;; XXX something here is broken +(defimplementation kill-thread (thread) + (threads:terminate-thread thread 'killed)) + +(defun mailbox (thread) + (with-lock *mailbox-lock* + (or (find thread *mailboxes* :key #'mailbox.thread) + (let ((mb (make-mailbox :thread thread))) + (push mb *mailboxes*) + mb)))) + +(defimplementation send (thread message) + (let ((mbox (mailbox thread))) + (with-lock (mailbox.lock mbox) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message)))))) + +(defimplementation receive () + (let ((mbox (mailbox cormanlisp:*current-thread-id*))) + (loop + (with-lock (mailbox.lock mbox) + (when (mailbox.queue mbox) + (return (pop (mailbox.queue mbox))))) + (sleep 0.1)))) + + +;;; This is probably not good, but it WFM +(in-package :common-lisp) + +(defvar *old-documentation* #'documentation) +(defun documentation (thing &optional (type 'function)) + (if (symbolp thing) + (funcall *old-documentation* thing type) + (values))) + +(defmethod print-object ((restart restart) stream) + (if (or *print-escape* + *print-readably*) + (print-unreadable-object (restart stream :type t :identity t) + (princ (restart-name restart) stream)) + (when (functionp (restart-report-function restart)) + (funcall (restart-report-function restart) stream)))) diff --git a/vim/bundle/slimv/slime/swank/ecl.lisp b/vim/bundle/slimv/slime/swank/ecl.lisp new file mode 100644 index 0000000..2d19c64 --- /dev/null +++ b/vim/bundle/slimv/slime/swank/ecl.lisp @@ -0,0 +1,845 @@ +;;;; -*- indent-tabs-mode: nil -*- +;;; +;;; swank-ecl.lisp --- SLIME backend for ECL. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +;;; Administrivia + +(defpackage swank/ecl + (:use cl swank/backend)) + +(in-package swank/ecl) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun ecl-version () + (let ((version (find-symbol "+ECL-VERSION-NUMBER+" :EXT))) + (if version + (symbol-value version) + 0))) + (when (< (ecl-version) 100301) + (error "~&IMPORTANT:~% ~ + The version of ECL you're using (~A) is too old.~% ~ + Please upgrade to at least 10.3.1.~% ~ + Sorry for the inconvenience.~%~%" + (lisp-implementation-version)))) + +;; Hard dependencies. +(eval-when (:compile-toplevel :load-toplevel :execute) + (require 'sockets)) + +;; Soft dependencies. +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (probe-file "sys:profile.fas") + (require :profile) + (pushnew :profile *features*)) + (when (probe-file "sys:serve-event.fas") + (require :serve-event) + (pushnew :serve-event *features*))) + +(declaim (optimize (debug 3))) + +;;; Swank-mop + +(eval-when (:compile-toplevel :load-toplevel :execute) + (import-swank-mop-symbols + :clos + (and (< (ecl-version) 121201) + `(:eql-specializer + :eql-specializer-object + :generic-function-declarations + :specializer-direct-methods + ,@(unless (fboundp 'clos:compute-applicable-methods-using-classes) + '(:compute-applicable-methods-using-classes)))))) + +(defimplementation gray-package-name () + "GRAY") + + +;;;; TCP Server + +(defimplementation preferred-communication-style () + ;; While ECL does provide threads, some parts of it are not + ;; thread-safe (2010-02-23), including the compiler and CLOS. + nil + ;; ECL on Windows does not provide condition-variables + ;; (or #+(and threads (not windows)) :spawn + ;; nil) + ) + +(defun resolve-hostname (name) + (car (sb-bsd-sockets:host-ent-addresses + (sb-bsd-sockets:get-host-by-name name)))) + +(defimplementation create-socket (host port &key backlog) + (let ((socket (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) + (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port) + (sb-bsd-sockets:socket-listen socket (or backlog 5)) + socket)) + +(defimplementation local-port (socket) + (nth-value 1 (sb-bsd-sockets:socket-name socket))) + +(defimplementation close-socket (socket) + (sb-bsd-sockets:socket-close socket)) + +(defimplementation accept-connection (socket + &key external-format + buffering timeout) + (declare (ignore timeout)) + (sb-bsd-sockets:socket-make-stream (accept socket) + :output t + :input t + :buffering (ecase buffering + ((t) :full) + ((nil) :none) + (:line :line)) + :element-type (if external-format + 'character + '(unsigned-byte 8)) + :external-format external-format)) +(defun accept (socket) + "Like socket-accept, but retry on EAGAIN." + (loop (handler-case + (return (sb-bsd-sockets:socket-accept socket)) + (sb-bsd-sockets:interrupted-error ())))) + +(defimplementation socket-fd (socket) + (etypecase socket + (fixnum socket) + (two-way-stream (socket-fd (two-way-stream-input-stream socket))) + (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket)) + (file-stream (si:file-stream-fd socket)))) + +(defvar *external-format-to-coding-system* + '((:latin-1 + "latin-1" "latin-1-unix" "iso-latin-1-unix" + "iso-8859-1" "iso-8859-1-unix") + (:utf-8 "utf-8" "utf-8-unix"))) + +(defun external-format (coding-system) + (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*)) + (find coding-system (ext:all-encodings) :test #'string-equal))) + +(defimplementation find-external-format (coding-system) + #+unicode (external-format coding-system) + ;; Without unicode support, ECL uses the one-byte encoding of the + ;; underlying OS, and will barf on anything except :DEFAULT. We + ;; return NIL here for known multibyte encodings, so + ;; SWANK:CREATE-SERVER will barf. + #-unicode (let ((xf (external-format coding-system))) + (if (member xf '(:utf-8)) + nil + :default))) + + +;;;; Unix Integration + +;;; If ECL is built with thread support, it'll spawn a helper thread +;;; executing the SIGINT handler. We do not want to BREAK into that +;;; helper but into the main thread, though. This is coupled with the +;;; current choice of NIL as communication-style in so far as ECL's +;;; main-thread is also the Slime's REPL thread. + +(defimplementation call-with-user-break-handler (real-handler function) + (let ((old-handler #'si:terminal-interrupt)) + (setf (symbol-function 'si:terminal-interrupt) + (make-interrupt-handler real-handler)) + (unwind-protect (funcall function) + (setf (symbol-function 'si:terminal-interrupt) old-handler)))) + +#+threads +(defun make-interrupt-handler (real-handler) + (let ((main-thread (find 'si:top-level (mp:all-processes) + :key #'mp:process-name))) + #'(lambda (&rest args) + (declare (ignore args)) + (mp:interrupt-process main-thread real-handler)))) + +#-threads +(defun make-interrupt-handler (real-handler) + #'(lambda (&rest args) + (declare (ignore args)) + (funcall real-handler))) + + +(defimplementation getpid () + (si:getpid)) + +(defimplementation set-default-directory (directory) + (ext:chdir (namestring directory)) ; adapts *DEFAULT-PATHNAME-DEFAULTS*. + (default-directory)) + +(defimplementation default-directory () + (namestring (ext:getcwd))) + +(defimplementation quit-lisp () + (ext:quit)) + + + +;;; Instead of busy waiting with communication-style NIL, use select() +;;; on the sockets' streams. +#+serve-event +(progn + (defun poll-streams (streams timeout) + (let* ((serve-event::*descriptor-handlers* + (copy-list serve-event::*descriptor-handlers*)) + (active-fds '()) + (fd-stream-alist + (loop for s in streams + for fd = (socket-fd s) + collect (cons fd s) + do (serve-event:add-fd-handler fd :input + #'(lambda (fd) + (push fd active-fds)))))) + (serve-event:serve-event timeout) + (loop for fd in active-fds collect (cdr (assoc fd fd-stream-alist))))) + + (defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (loop + (cond ((check-slime-interrupts) (return :interrupt)) + (timeout (return (poll-streams streams 0))) + (t + (when-let (ready (poll-streams streams 0.2)) + (return ready)))))) + +) ; #+serve-event (progn ... + +#-serve-event +(defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (loop + (cond ((check-slime-interrupts) (return :interrupt)) + (timeout (return (remove-if-not #'listen streams))) + (t + (let ((ready (remove-if-not #'listen streams))) + (if ready (return ready)) + (sleep 0.1)))))) + + +;;;; Compilation + +(defvar *buffer-name* nil) +(defvar *buffer-start-position*) + +(defun signal-compiler-condition (&rest args) + (apply #'signal 'compiler-condition args)) + +#-ecl-bytecmp +(defun handle-compiler-message (condition) + ;; ECL emits lots of noise in compiler-notes, like "Invoking + ;; external command". + (unless (typep condition 'c::compiler-note) + (signal-compiler-condition + :original-condition condition + :message (princ-to-string condition) + :severity (etypecase condition + (c:compiler-fatal-error :error) + (c:compiler-error :error) + (error :error) + (style-warning :style-warning) + (warning :warning)) + :location (condition-location condition)))) + +#-ecl-bytecmp +(defun condition-location (condition) + (let ((file (c:compiler-message-file condition)) + (position (c:compiler-message-file-position condition))) + (if (and position (not (minusp position))) + (if *buffer-name* + (make-buffer-location *buffer-name* + *buffer-start-position* + position) + (make-file-location file position)) + (make-error-location "No location found.")))) + +(defimplementation call-with-compilation-hooks (function) + #+ecl-bytecmp + (funcall function) + #-ecl-bytecmp + (handler-bind ((c:compiler-message #'handle-compiler-message)) + (funcall function))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (with-compilation-hooks () + (compile-file input-file :output-file output-file + :load load-p + :external-format external-format))) + +(defvar *tmpfile-map* (make-hash-table :test #'equal)) + +(defun note-buffer-tmpfile (tmp-file buffer-name) + ;; EXT:COMPILED-FUNCTION-FILE below will return a namestring. + (let ((tmp-namestring (namestring (truename tmp-file)))) + (setf (gethash tmp-namestring *tmpfile-map*) buffer-name) + tmp-namestring)) + +(defun tmpfile-to-buffer (tmp-file) + (gethash tmp-file *tmpfile-map*)) + +(defimplementation swank-compile-string (string &key buffer position filename + policy) + (declare (ignore policy)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) ; for compilation hooks + (*buffer-start-position* position)) + (let ((tmp-file (si:mkstemp "TMP:ecl-swank-tmpfile-")) + (fasl-file) + (warnings-p) + (failure-p)) + (unwind-protect + (with-open-file (tmp-stream tmp-file :direction :output + :if-exists :supersede) + (write-string string tmp-stream) + (finish-output tmp-stream) + (multiple-value-setq (fasl-file warnings-p failure-p) + (compile-file tmp-file + :load t + :source-truename (or filename + (note-buffer-tmpfile tmp-file buffer)) + :source-offset (1- position)))) + (when (probe-file tmp-file) + (delete-file tmp-file)) + (when fasl-file + (delete-file fasl-file))) + (not failure-p))))) + +;;;; Documentation + +(defimplementation arglist (name) + (multiple-value-bind (arglist foundp) + (ext:function-lambda-list name) + (if foundp arglist :not-available))) + +(defimplementation function-name (f) + (typecase f + (generic-function (clos:generic-function-name f)) + (function (si:compiled-function-name f)))) + +;; FIXME +;; (defimplementation macroexpand-all (form &optional env) +;; (declare (ignore env)) + +(defimplementation collect-macro-forms (form &optional env) + ;; Currently detects only normal macros, not compiler macros. + (declare (ignore env)) + (with-collected-macro-forms (macro-forms) + (handler-bind ((warning #'muffle-warning)) + (ignore-errors + (compile nil `(lambda () ,form)))) + (values macro-forms nil))) + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((frob (type boundp) + (when (funcall boundp symbol) + (let ((doc (describe-definition symbol type))) + (setf result (list* type doc result)))))) + (frob :VARIABLE #'boundp) + (frob :FUNCTION #'fboundp) + (frob :CLASS (lambda (x) (find-class x nil)))) + result)) + +(defimplementation describe-definition (name type) + (case type + (:variable (documentation name 'variable)) + (:function (documentation name 'function)) + (:class (documentation name 'class)) + (t nil))) + +(defimplementation type-specifier-p (symbol) + (or (subtypep nil symbol) + (not (eq (type-specifier-arglist symbol) :not-available)))) + + +;;; Debugging + +(eval-when (:compile-toplevel :load-toplevel :execute) + (import + '(si::*break-env* + si::*ihs-top* + si::*ihs-current* + si::*ihs-base* + si::*frs-base* + si::*frs-top* + si::*tpl-commands* + si::*tpl-level* + si::frs-top + si::ihs-top + si::ihs-fun + si::ihs-env + si::sch-frs-base + si::set-break-env + si::set-current-ihs + si::tpl-commands))) + +(defun make-invoke-debugger-hook (hook) + (when hook + #'(lambda (condition old-hook) + ;; Regard *debugger-hook* if set by user. + (if *debugger-hook* + nil ; decline, *DEBUGGER-HOOK* will be tried next. + (funcall hook condition old-hook))))) + +(defimplementation install-debugger-globally (function) + (setq *debugger-hook* function) + (setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function))) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook) + (ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))) + (funcall fun))) + +(defvar *backtrace* '()) + +;;; Commented out; it's not clear this is a good way of doing it. In +;;; particular because it makes errors stemming from this file harder +;;; to debug, and given the "young" age of ECL's swank backend, that's +;;; a bad idea. + +;; (defun in-swank-package-p (x) +;; (and +;; (symbolp x) +;; (member (symbol-package x) +;; (list #.(find-package :swank) +;; #.(find-package :swank/backend) +;; #.(ignore-errors (find-package :swank-mop)) +;; #.(ignore-errors (find-package :swank-loader)))) +;; t)) + +;; (defun is-swank-source-p (name) +;; (setf name (pathname name)) +;; (pathname-match-p +;; name +;; (make-pathname :defaults swank-loader::*source-directory* +;; :name (pathname-name name) +;; :type (pathname-type name) +;; :version (pathname-version name)))) + +;; (defun is-ignorable-fun-p (x) +;; (or +;; (in-swank-package-p (frame-name x)) +;; (multiple-value-bind (file position) +;; (ignore-errors (si::bc-file (car x))) +;; (declare (ignore position)) +;; (if file (is-swank-source-p file))))) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (declare (type function debugger-loop-fn)) + (let* ((*ihs-top* (ihs-top)) + (*ihs-current* *ihs-top*) + (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top)))) + (*frs-top* (frs-top)) + (*tpl-level* (1+ *tpl-level*)) + (*backtrace* (loop for ihs from 0 below *ihs-top* + collect (list (si::ihs-fun ihs) + (si::ihs-env ihs) + nil)))) + (declare (special *ihs-current*)) + (loop for f from *frs-base* until *frs-top* + do (let ((i (- (si::frs-ihs f) *ihs-base* 1))) + (when (plusp i) + (let* ((x (elt *backtrace* i)) + (name (si::frs-tag f))) + (unless (si::fixnump name) + (push name (third x))))))) + (setf *backtrace* (nreverse *backtrace*)) + (set-break-env) + (set-current-ihs) + (let ((*ihs-base* *ihs-top*)) + (funcall debugger-loop-fn)))) + +(defimplementation compute-backtrace (start end) + (subseq *backtrace* start + (and (numberp end) + (min end (length *backtrace*))))) + +(defun frame-name (frame) + (let ((x (first frame))) + (if (symbolp x) + x + (function-name x)))) + +(defun function-position (fun) + (multiple-value-bind (file position) + (si::bc-file fun) + (when file + (make-file-location file position)))) + +(defun frame-function (frame) + (let* ((x (first frame)) + fun position) + (etypecase x + (symbol (and (fboundp x) + (setf fun (fdefinition x) + position (function-position fun)))) + (function (setf fun x position (function-position x)))) + (values fun position))) + +(defun frame-decode-env (frame) + (let ((functions '()) + (blocks '()) + (variables '())) + (setf frame (si::decode-ihs-env (second frame))) + (dolist (record (remove-if-not #'consp frame)) + (let* ((record0 (car record)) + (record1 (cdr record))) + (cond ((or (symbolp record0) (stringp record0)) + (setq variables (acons record0 record1 variables))) + ((not (si::fixnump record0)) + (push record1 functions)) + ((symbolp record1) + (push record1 blocks)) + (t + )))) + (values functions blocks variables))) + +(defimplementation print-frame (frame stream) + (format stream "~A" (first frame))) + +(defimplementation frame-source-location (frame-number) + (nth-value 1 (frame-function (elt *backtrace* frame-number)))) + +(defimplementation frame-catch-tags (frame-number) + (third (elt *backtrace* frame-number))) + +(defimplementation frame-locals (frame-number) + (loop for (name . value) in (nth-value 2 (frame-decode-env + (elt *backtrace* frame-number))) + collect (list :name name :id 0 :value value))) + +(defimplementation frame-var-value (frame-number var-number) + (destructuring-bind (name . value) + (elt + (nth-value 2 (frame-decode-env (elt *backtrace* frame-number))) + var-number) + (declare (ignore name)) + value)) + +(defimplementation disassemble-frame (frame-number) + (let ((fun (frame-function (elt *backtrace* frame-number)))) + (disassemble fun))) + +(defimplementation eval-in-frame (form frame-number) + (let ((env (second (elt *backtrace* frame-number)))) + (si:eval-with-env form env))) + +(defimplementation gdb-initial-commands () + ;; These signals are used by the GC. + #+linux '("handle SIGPWR noprint nostop" + "handle SIGXCPU noprint nostop")) + +(defimplementation command-line-args () + (loop for n from 0 below (si:argc) collect (si:argv n))) + + +;;;; Inspector + +;;; FIXME: Would be nice if it was possible to inspect objects +;;; implemented in C. + + +;;;; Definitions + +(defvar +TAGS+ (namestring + (merge-pathnames "TAGS" (translate-logical-pathname "SYS:")))) + +(defun make-file-location (file file-position) + ;; File positions in CL start at 0, but Emacs' buffer positions + ;; start at 1. We specify (:ALIGN T) because the positions comming + ;; from ECL point at right after the toplevel form appearing before + ;; the actual target toplevel form; (:ALIGN T) will DTRT in that case. + (make-location `(:file ,(namestring (translate-logical-pathname file))) + `(:position ,(1+ file-position)) + `(:align t))) + +(defun make-buffer-location (buffer-name start-position &optional (offset 0)) + (make-location `(:buffer ,buffer-name) + `(:offset ,start-position ,offset) + `(:align t))) + +(defun make-TAGS-location (&rest tags) + (make-location `(:etags-file ,+TAGS+) + `(:tag ,@tags))) + +(defimplementation find-definitions (name) + (let ((annotations (ext:get-annotation name 'si::location :all))) + (cond (annotations + (loop for annotation in annotations + collect (destructuring-bind (dspec file . pos) annotation + `(,dspec ,(make-file-location file pos))))) + (t + (mapcan #'(lambda (type) (find-definitions-by-type name type)) + (classify-definition-name name)))))) + +(defun classify-definition-name (name) + (let ((types '())) + (when (fboundp name) + (cond ((special-operator-p name) + (push :special-operator types)) + ((macro-function name) + (push :macro types)) + ((typep (fdefinition name) 'generic-function) + (push :generic-function types)) + ((si:mangle-name name t) + (push :c-function types)) + (t + (push :lisp-function types)))) + (when (boundp name) + (cond ((constantp name) + (push :constant types)) + (t + (push :global-variable types)))) + types)) + +(defun find-definitions-by-type (name type) + (ecase type + (:lisp-function + (when-let (loc (source-location (fdefinition name))) + (list `((defun ,name) ,loc)))) + (:c-function + (when-let (loc (source-location (fdefinition name))) + (list `((c-source ,name) ,loc)))) + (:generic-function + (loop for method in (clos:generic-function-methods (fdefinition name)) + for specs = (clos:method-specializers method) + for loc = (source-location method) + when loc + collect `((defmethod ,name ,specs) ,loc))) + (:macro + (when-let (loc (source-location (macro-function name))) + (list `((defmacro ,name) ,loc)))) + (:constant + (when-let (loc (source-location name)) + (list `((defconstant ,name) ,loc)))) + (:global-variable + (when-let (loc (source-location name)) + (list `((defvar ,name) ,loc)))) + (:special-operator))) + +;;; FIXME: There ought to be a better way. +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun c-function-name-p (name) + (and (symbolp name) (si:mangle-name name t) t)) + (defun c-function-p (object) + (and (functionp object) + (let ((fn-name (function-name object))) + (and fn-name (c-function-name-p fn-name)))))) + +(deftype c-function () + `(satisfies c-function-p)) + +(defun assert-source-directory () + (unless (probe-file #P"SRC:") + (error "ECL's source directory ~A does not exist. ~ + You can specify a different location via the environment ~ + variable `ECLSRCDIR'." + (namestring (translate-logical-pathname #P"SYS:"))))) + +(defun assert-TAGS-file () + (unless (probe-file +TAGS+) + (error "No TAGS file ~A found. It should have been installed with ECL." + +TAGS+))) + +(defun package-names (package) + (cons (package-name package) (package-nicknames package))) + +(defun source-location (object) + (converting-errors-to-error-location + (typecase object + (c-function + (assert-source-directory) + (assert-TAGS-file) + (let ((lisp-name (function-name object))) + (assert lisp-name) + (multiple-value-bind (flag c-name) (si:mangle-name lisp-name t) + (assert flag) + ;; In ECL's code base sometimes the mangled name is used + ;; directly, sometimes ECL's DPP magic of @SI::SYMBOL or + ;; @EXT::SYMBOL is used. We cannot predict here, so we just + ;; provide several candidates. + (apply #'make-TAGS-location + c-name + (loop with s = (symbol-name lisp-name) + for p in (package-names (symbol-package lisp-name)) + collect (format nil "~A::~A" p s) + collect (format nil "~(~A::~A~)" p s)))))) + (function + (multiple-value-bind (file pos) (ext:compiled-function-file object) + (cond ((not file) + (return-from source-location nil)) + ((tmpfile-to-buffer file) + (make-buffer-location (tmpfile-to-buffer file) pos)) + (t + (assert (probe-file file)) + (assert (not (minusp pos))) + (make-file-location file pos))))) + (method + ;; FIXME: This will always return NIL at the moment; ECL does not + ;; store debug information for methods yet. + (source-location (clos:method-function object))) + ((member nil t) + (multiple-value-bind (flag c-name) (si:mangle-name object) + (assert flag) + (make-TAGS-location c-name)))))) + +(defimplementation find-source-location (object) + (or (source-location object) + (make-error-location "Source definition of ~S not found." object))) + + +;;;; Profiling + +#+profile +(progn + +(defimplementation profile (fname) + (when fname (eval `(profile:profile ,fname)))) + +(defimplementation unprofile (fname) + (when fname (eval `(profile:unprofile ,fname)))) + +(defimplementation unprofile-all () + (profile:unprofile-all) + "All functions unprofiled.") + +(defimplementation profile-report () + (profile:report)) + +(defimplementation profile-reset () + (profile:reset) + "Reset profiling counters.") + +(defimplementation profiled-functions () + (profile:profile)) + +(defimplementation profile-package (package callers methods) + (declare (ignore callers methods)) + (eval `(profile:profile ,(package-name (find-package package))))) +) ; #+profile (progn ... + + +;;;; Threads + +#+threads +(progn + (defvar *thread-id-counter* 0) + + (defparameter *thread-id-map* (make-hash-table)) + + (defvar *thread-id-map-lock* + (mp:make-lock :name "thread id map lock")) + + (defimplementation spawn (fn &key name) + (mp:process-run-function name fn)) + + (defimplementation thread-id (target-thread) + (block thread-id + (mp:with-lock (*thread-id-map-lock*) + ;; Does TARGET-THREAD have an id already? + (maphash (lambda (id thread-pointer) + (let ((thread (si:weak-pointer-value thread-pointer))) + (cond ((not thread) + (remhash id *thread-id-map*)) + ((eq thread target-thread) + (return-from thread-id id))))) + *thread-id-map*) + ;; TARGET-THREAD not found in *THREAD-ID-MAP* + (let ((id (incf *thread-id-counter*)) + (thread-pointer (si:make-weak-pointer target-thread))) + (setf (gethash id *thread-id-map*) thread-pointer) + id)))) + + (defimplementation find-thread (id) + (mp:with-lock (*thread-id-map-lock*) + (let* ((thread-ptr (gethash id *thread-id-map*)) + (thread (and thread-ptr (si:weak-pointer-value thread-ptr)))) + (unless thread + (remhash id *thread-id-map*)) + thread))) + + (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 :recursive t)) + + (defimplementation call-with-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")) + (defvar *mailboxes* (list)) + (declaim (type list *mailboxes*)) + + (defstruct (mailbox (:conc-name mailbox.)) + thread + (mutex (mp:make-lock)) + (cvar (mp:make-condition-variable)) + (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:with-lock (mutex) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + (mp:condition-variable-broadcast (mailbox.cvar mbox))))) + + (defimplementation receive-if (test &optional timeout) + (let* ((mbox (mailbox (current-thread))) + (mutex (mailbox.mutex mbox))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (mp:with-lock (mutex) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail)))) + (when (eq timeout t) (return (values nil t))) + (mp:condition-variable-timedwait (mailbox.cvar mbox) + mutex + 0.2))))) + + ) ; #+threads (progn ... diff --git a/vim/bundle/slimv/slime/swank/gray.lisp b/vim/bundle/slimv/slime/swank/gray.lisp new file mode 100644 index 0000000..b910a78 --- /dev/null +++ b/vim/bundle/slimv/slime/swank/gray.lisp @@ -0,0 +1,170 @@ +;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- +;;; +;;; swank-gray.lisp --- Gray stream based IO redirection. +;;; +;;; Created 2003 +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(in-package swank/backend) + +#.(progn + (defvar *gray-stream-symbols* + '(fundamental-character-output-stream + stream-write-char + stream-write-string + stream-fresh-line + stream-force-output + stream-finish-output + + fundamental-character-input-stream + stream-read-char + stream-peek-char + stream-read-line + stream-listen + stream-unread-char + stream-clear-input + stream-line-column + stream-read-char-no-hang)) + nil) + +(defpackage swank/gray + (:use cl swank/backend) + (:import-from #.(gray-package-name) . #.*gray-stream-symbols*) + (:export . #.*gray-stream-symbols*)) + +(in-package swank/gray) + +(defclass slime-output-stream (fundamental-character-output-stream) + ((output-fn :initarg :output-fn) + (buffer :initform (make-string 8000)) + (fill-pointer :initform 0) + (column :initform 0) + (lock :initform (make-lock :name "buffer write lock")))) + +(defmacro with-slime-output-stream (stream &body body) + `(with-slots (lock output-fn buffer fill-pointer column) ,stream + (call-with-lock-held lock (lambda () ,@body)))) + +(defmethod stream-write-char ((stream slime-output-stream) char) + (with-slime-output-stream stream + (setf (schar buffer fill-pointer) char) + (incf fill-pointer) + (incf column) + (when (char= #\newline char) + (setf column 0)) + (when (= fill-pointer (length buffer)) + (finish-output stream))) + char) + +(defmethod stream-write-string ((stream slime-output-stream) string + &optional start end) + (with-slime-output-stream stream + (let* ((start (or start 0)) + (end (or end (length string))) + (len (length buffer)) + (count (- end start)) + (free (- len fill-pointer))) + (when (>= count free) + (stream-finish-output stream)) + (cond ((< count len) + (replace buffer string :start1 fill-pointer + :start2 start :end2 end) + (incf fill-pointer count)) + (t + (funcall output-fn (subseq string start end)))) + (let ((last-newline (position #\newline string :from-end t + :start start :end end))) + (setf column (if last-newline + (- end last-newline 1) + (+ column count)))))) + string) + +(defmethod stream-line-column ((stream slime-output-stream)) + (with-slime-output-stream stream column)) + +(defmethod stream-finish-output ((stream slime-output-stream)) + (with-slime-output-stream stream + (unless (zerop fill-pointer) + (funcall output-fn (subseq buffer 0 fill-pointer)) + (setf fill-pointer 0))) + nil) + +(defmethod stream-force-output ((stream slime-output-stream)) + (stream-finish-output stream)) + +(defmethod stream-fresh-line ((stream slime-output-stream)) + (with-slime-output-stream stream + (cond ((zerop column) nil) + (t (terpri stream) t)))) + +(defclass slime-input-stream (fundamental-character-input-stream) + ((input-fn :initarg :input-fn) + (buffer :initform "") (index :initform 0) + (lock :initform (make-lock :name "buffer read lock")))) + +(defmethod stream-read-char ((s slime-input-stream)) + (call-with-lock-held + (slot-value s 'lock) + (lambda () + (with-slots (buffer index input-fn) s + (when (= index (length buffer)) + (let ((string (funcall input-fn))) + (cond ((zerop (length string)) + (return-from stream-read-char :eof)) + (t + (setf buffer string) + (setf index 0))))) + (assert (plusp (length buffer))) + (prog1 (aref buffer index) (incf index)))))) + +(defmethod stream-listen ((s slime-input-stream)) + (call-with-lock-held + (slot-value s 'lock) + (lambda () + (with-slots (buffer index) s + (< index (length buffer)))))) + +(defmethod stream-unread-char ((s slime-input-stream) char) + (call-with-lock-held + (slot-value s 'lock) + (lambda () + (with-slots (buffer index) s + (decf index) + (cond ((eql (aref buffer index) char) + (setf (aref buffer index) char)) + (t + (warn "stream-unread-char: ignoring ~S (expected ~S)" + char (aref buffer index))))))) + nil) + +(defmethod stream-clear-input ((s slime-input-stream)) + (call-with-lock-held + (slot-value s 'lock) + (lambda () + (with-slots (buffer index) s + (setf buffer "" + index 0)))) + nil) + +(defmethod stream-line-column ((s slime-input-stream)) + nil) + +(defmethod stream-read-char-no-hang ((s slime-input-stream)) + (call-with-lock-held + (slot-value s 'lock) + (lambda () + (with-slots (buffer index) s + (when (< index (length buffer)) + (prog1 (aref buffer index) (incf index))))))) + + +;;; + +(defimplementation make-output-stream (write-string) + (make-instance 'slime-output-stream :output-fn write-string)) + +(defimplementation make-input-stream (read-string) + (make-instance 'slime-input-stream :input-fn read-string)) diff --git a/vim/bundle/slimv/slime/swank/lispworks.lisp b/vim/bundle/slimv/slime/swank/lispworks.lisp new file mode 100644 index 0000000..d4b656e --- /dev/null +++ b/vim/bundle/slimv/slime/swank/lispworks.lisp @@ -0,0 +1,1018 @@ +;;; -*- indent-tabs-mode: nil -*- +;;; +;;; swank-lispworks.lisp --- LispWorks specific code for SLIME. +;;; +;;; Created 2003, Helmut Eller +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(defpackage swank/lispworks + (:use cl swank/backend)) + +(in-package swank/lispworks) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "comm")) + +(defimplementation gray-package-name () + "STREAM") + +(import-swank-mop-symbols :clos '(:slot-definition-documentation + :slot-boundp-using-class + :slot-value-using-class + :slot-makunbound-using-class + :eql-specializer + :eql-specializer-object + :compute-applicable-methods-using-classes)) + +(defun swank-mop:slot-definition-documentation (slot) + (documentation slot t)) + +(defun swank-mop:slot-boundp-using-class (class object slotd) + (clos:slot-boundp-using-class class object + (clos:slot-definition-name slotd))) + +(defun swank-mop:slot-value-using-class (class object slotd) + (clos:slot-value-using-class class object + (clos:slot-definition-name slotd))) + +(defun (setf swank-mop:slot-value-using-class) (value class object slotd) + (setf (clos:slot-value-using-class class object + (clos:slot-definition-name slotd)) + value)) + +(defun swank-mop:slot-makunbound-using-class (class object slotd) + (clos:slot-makunbound-using-class class object + (clos:slot-definition-name slotd))) + +(defun swank-mop:compute-applicable-methods-using-classes (gf classes) + (clos::compute-applicable-methods-from-classes gf classes)) + +;; lispworks doesn't have the eql-specializer class, it represents +;; them as a list of `(EQL ,OBJECT) +(deftype swank-mop:eql-specializer () 'cons) + +(defun swank-mop:eql-specializer-object (eql-spec) + (second eql-spec)) + +(eval-when (:compile-toplevel :execute :load-toplevel) + (defvar *original-defimplementation* (macro-function 'defimplementation)) + (defmacro defimplementation (&whole whole name args &body body + &environment env) + (declare (ignore args body)) + `(progn + (dspec:record-definition '(defun ,name) (dspec:location) + :check-redefinition-p nil) + ,(funcall *original-defimplementation* whole env)))) + +;;; UTF8 + +(defimplementation string-to-utf8 (string) + (ef:encode-lisp-string string '(:utf-8 :eol-style :lf))) + +(defimplementation utf8-to-string (octets) + (ef:decode-external-string octets '(:utf-8 :eol-style :lf))) + +;;; TCP server + +(defimplementation preferred-communication-style () + :spawn) + +(defun socket-fd (socket) + (etypecase socket + (fixnum socket) + (comm:socket-stream (comm:socket-stream-socket socket)))) + +(defimplementation create-socket (host port &key backlog) + (multiple-value-bind (socket where errno) + #-(or lispworks4.1 (and macosx lispworks4.3)) + (comm::create-tcp-socket-for-service port :address host + :backlog (or backlog 5)) + #+(or lispworks4.1 (and macosx lispworks4.3)) + (comm::create-tcp-socket-for-service port) + (cond (socket socket) + (t (error 'network-error + :format-control "~A failed: ~A (~D)" + :format-arguments (list where + (list #+unix (lw:get-unix-error errno)) + errno)))))) + +(defimplementation local-port (socket) + (nth-value 1 (comm:get-socket-address (socket-fd socket)))) + +(defimplementation close-socket (socket) + (comm::close-socket (socket-fd socket))) + +(defimplementation accept-connection (socket + &key external-format buffering timeout) + (declare (ignore buffering)) + (let* ((fd (comm::get-fd-from-socket socket))) + (assert (/= fd -1)) + (cond ((not external-format) + (make-instance 'comm:socket-stream + :socket fd + :direction :io + :read-timeout timeout + :element-type '(unsigned-byte 8))) + (t + (assert (valid-external-format-p external-format)) + (ecase (first external-format) + ((:latin-1 :ascii) + (make-instance 'comm:socket-stream + :socket fd + :direction :io + :read-timeout timeout + :element-type 'base-char)) + (:utf-8 + (make-flexi-stream + (make-instance 'comm:socket-stream + :socket fd + :direction :io + :read-timeout timeout + :element-type '(unsigned-byte 8)) + external-format))))))) + +(defun make-flexi-stream (stream external-format) + (unless (member :flexi-streams *features*) + (error "Cannot use external format ~A~ + without having installed flexi-streams in the inferior-lisp." + external-format)) + (funcall (read-from-string "FLEXI-STREAMS:MAKE-FLEXI-STREAM") + stream + :external-format + (apply (read-from-string "FLEXI-STREAMS:MAKE-EXTERNAL-FORMAT") + external-format))) + +;;; Coding Systems + +(defun valid-external-format-p (external-format) + (member external-format *external-format-to-coding-system* + :test #'equal :key #'car)) + +(defvar *external-format-to-coding-system* + '(((:latin-1 :eol-style :lf) + "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix") + ;;((:latin-1) "latin-1" "iso-latin-1" "iso-8859-1") + ;;((:utf-8) "utf-8") + ((:utf-8 :eol-style :lf) "utf-8-unix") + ;;((:euc-jp) "euc-jp") + ((:euc-jp :eol-style :lf) "euc-jp-unix") + ;;((:ascii) "us-ascii") + ((:ascii :eol-style :lf) "us-ascii-unix"))) + +(defimplementation find-external-format (coding-system) + (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + +;;; Unix signals + +(defun sigint-handler () + (with-simple-restart (continue "Continue from SIGINT handler.") + (invoke-debugger "SIGINT"))) + +(defun make-sigint-handler (process) + (lambda (&rest args) + (declare (ignore args)) + (mp:process-interrupt process #'sigint-handler))) + +(defun set-sigint-handler () + ;; Set SIGINT handler on Swank request handler thread. + #-win32 + (sys::set-signal-handler +sigint+ + (make-sigint-handler mp:*current-process*))) + +#-win32 +(defimplementation install-sigint-handler (handler) + (sys::set-signal-handler +sigint+ + (let ((self mp:*current-process*)) + (lambda (&rest args) + (declare (ignore args)) + (mp:process-interrupt self handler))))) + +(defimplementation getpid () + #+win32 (win32:get-current-process-id) + #-win32 (system::getpid)) + +(defimplementation lisp-implementation-type-name () + "lispworks") + +(defimplementation set-default-directory (directory) + (namestring (hcl:change-directory directory))) + +;;;; Documentation + +(defun map-list (function list) + "Map over proper and not proper lists." + (loop for (car . cdr) on list + collect (funcall function car) into result + when (null cdr) return result + when (atom cdr) return (nconc result (funcall function cdr)))) + +(defun replace-strings-with-symbols (tree) + (map-list + (lambda (x) + (typecase x + (list + (replace-strings-with-symbols x)) + (symbol + x) + (string + (intern x)) + (t + (intern (write-to-string x))))) + tree)) + +(defimplementation arglist (symbol-or-function) + (let ((arglist (lw:function-lambda-list symbol-or-function))) + (etypecase arglist + ((member :dont-know) + :not-available) + (list + (replace-strings-with-symbols arglist))))) + +(defimplementation function-name (function) + (nth-value 2 (function-lambda-expression function))) + +(defimplementation macroexpand-all (form &optional env) + (declare (ignore env)) + (walker:walk-form form)) + +(defun generic-function-p (object) + (typep object 'generic-function)) + +(defimplementation describe-symbol-for-emacs (symbol) + "Return a plist describing SYMBOL. +Return NIL if the symbol is unbound." + (let ((result '())) + (labels ((first-line (string) + (let ((pos (position #\newline string))) + (if (null pos) string (subseq string 0 pos)))) + (doc (kind &optional (sym symbol)) + (let ((string (or (documentation sym kind)))) + (if string + (first-line string) + :not-documented))) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (when (boundp symbol) + (doc 'variable))) + (maybe-push + :generic-function (if (and (fboundp symbol) + (generic-function-p (fdefinition symbol))) + (doc 'function))) + (maybe-push + :function (if (and (fboundp symbol) + (not (generic-function-p (fdefinition symbol)))) + (doc 'function))) + (maybe-push + :setf (let ((setf-name (sys:underlying-setf-name `(setf ,symbol)))) + (if (fboundp setf-name) + (doc 'setf)))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + result))) + +(defimplementation describe-definition (symbol type) + (ecase type + (:variable (describe-symbol symbol)) + (:class (describe (find-class symbol))) + ((:function :generic-function) (describe-function symbol)) + (:setf (describe-function (sys:underlying-setf-name `(setf ,symbol)))))) + +(defun describe-function (symbol) + (cond ((fboundp symbol) + (format t "(~A ~/pprint-fill/)~%~%~:[(not documented)~;~:*~A~]~%" + symbol + (lispworks:function-lambda-list symbol) + (documentation symbol 'function)) + (describe (fdefinition symbol))) + (t (format t "~S is not fbound" symbol)))) + +(defun describe-symbol (sym) + (format t "~A is a symbol in package ~A." sym (symbol-package sym)) + (when (boundp sym) + (format t "~%~%Value: ~A" (symbol-value sym))) + (let ((doc (documentation sym 'variable))) + (when doc + (format t "~%~%Variable documentation:~%~A" doc))) + (when (fboundp sym) + (describe-function sym))) + +(defimplementation type-specifier-p (symbol) + (or (ignore-errors + (subtypep nil symbol)) + (not (eq (type-specifier-arglist symbol) :not-available)))) + +;;; Debugging + +(defclass slime-env (env:environment) + ((debugger-hook :initarg :debugger-hoook))) + +(defun slime-env (hook io-bindings) + (make-instance 'slime-env :name "SLIME Environment" + :io-bindings io-bindings + :debugger-hoook hook)) + +(defmethod env-internals:environment-display-notifier + ((env slime-env) &key restarts condition) + (declare (ignore restarts condition)) + (swank:swank-debugger-hook condition *debugger-hook*)) + +(defmethod env-internals:environment-display-debugger ((env slime-env)) + *debug-io*) + +(defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args) + (apply #'swank:y-or-n-p-in-emacs msg args)) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook)) + (env:with-environment ((slime-env hook '())) + (funcall fun)))) + +(defimplementation install-debugger-globally (function) + (setq *debugger-hook* function) + (setf (env:environment) (slime-env function '()))) + +(defvar *sldb-top-frame*) + +(defun interesting-frame-p (frame) + (cond ((or (dbg::call-frame-p frame) + (dbg::derived-call-frame-p frame) + (dbg::foreign-frame-p frame) + (dbg::interpreted-call-frame-p frame)) + t) + ((dbg::catch-frame-p frame) dbg:*print-catch-frames*) + ((dbg::binding-frame-p frame) dbg:*print-binding-frames*) + ((dbg::handler-frame-p frame) dbg:*print-handler-frames*) + ((dbg::restart-frame-p frame) dbg:*print-restart-frames*) + (t nil))) + +(defun nth-next-frame (frame n) + "Unwind FRAME N times." + (do ((frame frame (dbg::frame-next frame)) + (i n (if (interesting-frame-p frame) (1- i) i))) + ((or (not frame) + (and (interesting-frame-p frame) (zerop i))) + frame))) + +(defun nth-frame (index) + (nth-next-frame *sldb-top-frame* index)) + +(defun find-top-frame () + "Return the most suitable top-frame for the debugger." + (flet ((find-named-frame (name) + (do ((frame (dbg::debugger-stack-current-frame + dbg::*debugger-stack*) + (nth-next-frame frame 1))) + ((or (null frame) ; no frame found! + (and (dbg::call-frame-p frame) + (eq (dbg::call-frame-function-name frame) + name))) + (nth-next-frame frame 1))))) + (or (find-named-frame 'invoke-debugger) + (find-named-frame 'swank::safe-backtrace) + ;; if we can't find a likely top frame, take any old frame + ;; at the top + (dbg::debugger-stack-current-frame dbg::*debugger-stack*)))) + +(defimplementation call-with-debugging-environment (fn) + (dbg::with-debugger-stack () + (let ((*sldb-top-frame* (find-top-frame))) + (funcall fn)))) + +(defimplementation compute-backtrace (start end) + (let ((end (or end most-positive-fixnum)) + (backtrace '())) + (do ((frame (nth-frame start) (dbg::frame-next frame)) + (i start)) + ((or (not frame) (= i end)) (nreverse backtrace)) + (when (interesting-frame-p frame) + (incf i) + (push frame backtrace))))) + +(defun frame-actual-args (frame) + (let ((*break-on-signals* nil) + (kind nil)) + (loop for arg in (dbg::call-frame-arglist frame) + if (eq kind '&rest) + nconc (handler-case + (dbg::dbg-eval arg frame) + (error (e) (list (format nil "<~A>" arg)))) + and do (loop-finish) + else + if (member arg '(&rest &optional &key)) + do (setq kind arg) + else + nconc + (handler-case + (nconc (and (eq kind '&key) + (list (cond ((symbolp arg) + (intern (symbol-name arg) :keyword)) + ((and (consp arg) (symbolp (car arg))) + (intern (symbol-name (car arg)) + :keyword)) + (t (caar arg))))) + (list (dbg::dbg-eval + (cond ((symbolp arg) arg) + ((and (consp arg) (symbolp (car arg))) + (car arg)) + (t (cadar arg))) + frame))) + (error (e) (list (format nil "<~A>" arg))))))) + +(defimplementation print-frame (frame stream) + (cond ((dbg::call-frame-p frame) + (prin1 (cons (dbg::call-frame-function-name frame) + (frame-actual-args frame)) + stream)) + (t (princ frame stream)))) + +(defun frame-vars (frame) + (first (dbg::frame-locals-format-list frame #'list 75 0))) + +(defimplementation frame-locals (n) + (let ((frame (nth-frame n))) + (if (dbg::call-frame-p frame) + (mapcar (lambda (var) + (destructuring-bind (name value symbol location) var + (declare (ignore name location)) + (list :name symbol :id 0 + :value value))) + (frame-vars frame))))) + +(defimplementation frame-var-value (frame var) + (let ((frame (nth-frame frame))) + (destructuring-bind (_n value _s _l) (nth var (frame-vars frame)) + (declare (ignore _n _s _l)) + value))) + +(defimplementation frame-source-location (frame) + (let ((frame (nth-frame frame)) + (callee (if (plusp frame) (nth-frame (1- frame))))) + (if (dbg::call-frame-p frame) + (let ((dspec (dbg::call-frame-function-name frame)) + (cname (and (dbg::call-frame-p callee) + (dbg::call-frame-function-name callee))) + (path (and (dbg::call-frame-p frame) + (dbg::call-frame-edit-path frame)))) + (if dspec + (frame-location dspec cname path)))))) + +(defimplementation eval-in-frame (form frame-number) + (let ((frame (nth-frame frame-number))) + (dbg::dbg-eval form frame))) + +(defun function-name-package (name) + (typecase name + (null nil) + (symbol (symbol-package name)) + ((cons (eql hcl:subfunction)) + (destructuring-bind (name parent) (cdr name) + (declare (ignore name)) + (function-name-package parent))) + ((cons (eql lw:top-level-form)) nil) + (t nil))) + +(defimplementation frame-package (frame-number) + (let ((frame (nth-frame frame-number))) + (if (dbg::call-frame-p frame) + (function-name-package (dbg::call-frame-function-name frame))))) + +(defimplementation return-from-frame (frame-number form) + (let* ((frame (nth-frame frame-number)) + (return-frame (dbg::find-frame-for-return frame))) + (dbg::dbg-return-from-call-frame frame form return-frame + dbg::*debugger-stack*))) + +(defimplementation restart-frame (frame-number) + (let ((frame (nth-frame frame-number))) + (dbg::restart-frame frame :same-args t))) + +(defimplementation disassemble-frame (frame-number) + (let* ((frame (nth-frame frame-number))) + (when (dbg::call-frame-p frame) + (let ((function (dbg::get-call-frame-function frame))) + (disassemble function))))) + +;;; Definition finding + +(defun frame-location (dspec callee-name edit-path) + (let ((infos (dspec:find-dspec-locations dspec))) + (cond (infos + (destructuring-bind ((rdspec location) &rest _) infos + (declare (ignore _)) + (let ((name (and callee-name (symbolp callee-name) + (string callee-name))) + (path (edit-path-to-cmucl-source-path edit-path))) + (make-dspec-location rdspec location + `(:call-site ,name :edit-path ,path))))) + (t + (list :error (format nil "Source location not available for: ~S" + dspec)))))) + +;; dbg::call-frame-edit-path is not documented but lets assume the +;; binary representation of the integer EDIT-PATH should be +;; interpreted as a sequence of CAR or CDR. #b1111010 is roughly the +;; same as cadadddr. Something is odd with the highest bit. +(defun edit-path-to-cmucl-source-path (edit-path) + (and edit-path + (cons 0 + (let ((n -1)) + (loop for i from (1- (integer-length edit-path)) downto 0 + if (logbitp i edit-path) do (incf n) + else collect (prog1 n (setq n 0))))))) + +;; (edit-path-to-cmucl-source-path #b1111010) => (0 3 1) + +(defimplementation find-definitions (name) + (let ((locations (dspec:find-name-locations dspec:*dspec-classes* name))) + (loop for (dspec location) in locations + collect (list dspec (make-dspec-location dspec location))))) + + +;;; Compilation + +(defmacro with-swank-compilation-unit ((location &rest options) &body body) + (lw:rebinding (location) + `(let ((compiler::*error-database* '())) + (with-compilation-unit ,options + (multiple-value-prog1 (progn ,@body) + (signal-error-data-base compiler::*error-database* + ,location) + (signal-undefined-functions compiler::*unknown-functions* + ,location)))))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (with-swank-compilation-unit (input-file) + (compile-file input-file + :output-file output-file + :load load-p + :external-format external-format))) + +(defvar *within-call-with-compilation-hooks* nil + "Whether COMPILE-FILE was called from within CALL-WITH-COMPILATION-HOOKS.") + +(defvar *undefined-functions-hash* nil + "Hash table to map info about undefined functions to pathnames.") + +(lw:defadvice (compile-file compile-file-and-collect-notes :around) + (pathname &rest rest) + (multiple-value-prog1 (apply #'lw:call-next-advice pathname rest) + (when *within-call-with-compilation-hooks* + (maphash (lambda (unfun dspecs) + (dolist (dspec dspecs) + (let ((unfun-info (list unfun dspec))) + (unless (gethash unfun-info *undefined-functions-hash*) + (setf (gethash unfun-info *undefined-functions-hash*) + pathname))))) + compiler::*unknown-functions*)))) + +(defimplementation call-with-compilation-hooks (function) + (let ((compiler::*error-database* '()) + (*undefined-functions-hash* (make-hash-table :test 'equal)) + (*within-call-with-compilation-hooks* t)) + (with-compilation-unit () + (prog1 (funcall function) + (signal-error-data-base compiler::*error-database*) + (signal-undefined-functions compiler::*unknown-functions*))))) + +(defun map-error-database (database fn) + (loop for (filename . defs) in database do + (loop for (dspec . conditions) in defs do + (dolist (c conditions) + (multiple-value-bind (condition path) + (if (consp c) (values (car c) (cdr c)) (values c nil)) + (funcall fn filename dspec condition path)))))) + +(defun lispworks-severity (condition) + (cond ((not condition) :warning) + (t (etypecase condition + #-(or lispworks4 lispworks5) + (conditions:compiler-note :note) + (error :error) + (style-warning :warning) + (warning :warning))))) + +(defun signal-compiler-condition (message location condition) + (check-type message string) + (signal + (make-instance 'compiler-condition :message message + :severity (lispworks-severity condition) + :location location + :original-condition condition))) + +(defvar *temp-file-format* '(:utf-8 :eol-style :lf)) + +(defun compile-from-temp-file (string filename) + (unwind-protect + (progn + (with-open-file (s filename :direction :output + :if-exists :supersede + :external-format *temp-file-format*) + + (write-string string s) + (finish-output s)) + (multiple-value-bind (binary-filename warnings? failure?) + (compile-file filename :load t + :external-format *temp-file-format*) + (declare (ignore warnings?)) + (when binary-filename + (delete-file binary-filename)) + (not failure?))) + (delete-file filename))) + +(defun dspec-function-name-position (dspec fallback) + (etypecase dspec + (cons (let ((name (dspec:dspec-primary-name dspec))) + (typecase name + ((or symbol string) + (list :function-name (string name))) + (t fallback)))) + (null fallback) + (symbol (list :function-name (string dspec))))) + +(defmacro with-fairly-standard-io-syntax (&body body) + "Like WITH-STANDARD-IO-SYNTAX but preserve *PACKAGE* and *READTABLE*." + (let ((package (gensym)) + (readtable (gensym))) + `(let ((,package *package*) + (,readtable *readtable*)) + (with-standard-io-syntax + (let ((*package* ,package) + (*readtable* ,readtable)) + ,@body))))) + +(defun skip-comments (stream) + (let ((pos0 (file-position stream))) + (cond ((equal (ignore-errors (list (read-delimited-list #\( stream))) + '(())) + (file-position stream (1- (file-position stream)))) + (t (file-position stream pos0))))) + +#-(or lispworks4.1 lispworks4.2) ; no dspec:parse-form-dspec prior to 4.3 +(defun dspec-stream-position (stream dspec) + (with-fairly-standard-io-syntax + (loop (let* ((pos (progn (skip-comments stream) (file-position stream))) + (form (read stream nil '#1=#:eof))) + (when (eq form '#1#) + (return nil)) + (labels ((check-dspec (form) + (when (consp form) + (let ((operator (car form))) + (case operator + ((progn) + (mapcar #'check-dspec + (cdr form))) + ((eval-when locally macrolet symbol-macrolet) + (mapcar #'check-dspec + (cddr form))) + ((in-package) + (let ((package (find-package (second form)))) + (when package + (setq *package* package)))) + (otherwise + (let ((form-dspec (dspec:parse-form-dspec form))) + (when (dspec:dspec-equal dspec form-dspec) + (return pos))))))))) + (check-dspec form)))))) + +(defun dspec-file-position (file dspec) + (let* ((*compile-file-pathname* (pathname file)) + (*compile-file-truename* (truename *compile-file-pathname*)) + (*load-pathname* *compile-file-pathname*) + (*load-truename* *compile-file-truename*)) + (with-open-file (stream file) + (let ((pos + #-(or lispworks4.1 lispworks4.2) + (ignore-errors (dspec-stream-position stream dspec)))) + (if pos + (list :position (1+ pos)) + (dspec-function-name-position dspec `(:position 1))))))) + +(defun emacs-buffer-location-p (location) + (and (consp location) + (eq (car location) :emacs-buffer))) + +(defun make-dspec-location (dspec location &optional hints) + (etypecase location + ((or pathname string) + (multiple-value-bind (file err) + (ignore-errors (namestring (truename location))) + (if err + (list :error (princ-to-string err)) + (make-location `(:file ,file) + (dspec-file-position file dspec) + hints)))) + (symbol + `(:error ,(format nil "Cannot resolve location: ~S" location))) + ((satisfies emacs-buffer-location-p) + (destructuring-bind (_ buffer offset) location + (declare (ignore _)) + (make-location `(:buffer ,buffer) + (dspec-function-name-position dspec `(:offset ,offset 0)) + hints))))) + +(defun make-dspec-progenitor-location (dspec location edit-path) + (let ((canon-dspec (dspec:canonicalize-dspec dspec))) + (make-dspec-location + (if canon-dspec + (if (dspec:local-dspec-p canon-dspec) + (dspec:dspec-progenitor canon-dspec) + canon-dspec) + nil) + location + (if edit-path + (list :edit-path (edit-path-to-cmucl-source-path edit-path)))))) + +(defun signal-error-data-base (database &optional location) + (map-error-database + database + (lambda (filename dspec condition edit-path) + (signal-compiler-condition + (format nil "~A" condition) + (make-dspec-progenitor-location dspec (or location filename) edit-path) + condition)))) + +(defun unmangle-unfun (symbol) + "Converts symbols like 'SETF::|\"CL-USER\" \"GET\"| to +function names like \(SETF GET)." + (cond ((sys::setf-symbol-p symbol) + (sys::setf-pair-from-underlying-name symbol)) + (t symbol))) + +(defun signal-undefined-functions (htab &optional filename) + (maphash (lambda (unfun dspecs) + (dolist (dspec dspecs) + (signal-compiler-condition + (format nil "Undefined function ~A" (unmangle-unfun unfun)) + (make-dspec-progenitor-location + dspec + (or filename + (gethash (list unfun dspec) *undefined-functions-hash*)) + nil) + nil))) + htab)) + +(defimplementation swank-compile-string (string &key buffer position filename + policy) + (declare (ignore filename policy)) + (assert buffer) + (assert position) + (let* ((location (list :emacs-buffer buffer position)) + (tmpname (hcl:make-temp-file nil "lisp"))) + (with-swank-compilation-unit (location) + (compile-from-temp-file + (with-output-to-string (s) + (let ((*print-radix* t)) + (print `(eval-when (:compile-toplevel) + (setq dspec::*location* (list ,@location))) + s)) + (write-string string s)) + tmpname)))) + +;;; xref + +(defmacro defxref (name function) + `(defimplementation ,name (name) + (xref-results (,function name)))) + +(defxref who-calls hcl:who-calls) +(defxref who-macroexpands hcl:who-calls) ; macros are in the calls table too +(defxref calls-who hcl:calls-who) +(defxref list-callers list-callers-internal) +(defxref list-callees list-callees-internal) + +(defun list-callers-internal (name) + (let ((callers (make-array 100 + :fill-pointer 0 + :adjustable t))) + (hcl:sweep-all-objects + #'(lambda (object) + (when (and #+Harlequin-PC-Lisp (low:compiled-code-p object) + #+Harlequin-Unix-Lisp (sys:callablep object) + #-(or Harlequin-PC-Lisp Harlequin-Unix-Lisp) + (sys:compiled-code-p object) + (system::find-constant$funcallable name object)) + (vector-push-extend object callers)))) + ;; Delay dspec:object-dspec until after sweep-all-objects + ;; to reduce allocation problems. + (loop for object across callers + collect (if (symbolp object) + (list 'function object) + (or (dspec:object-dspec object) object))))) + +(defun list-callees-internal (name) + (let ((callees '())) + (system::find-constant$funcallable + 'junk name + :test #'(lambda (junk constant) + (declare (ignore junk)) + (when (and (symbolp constant) + (fboundp constant)) + (pushnew (list 'function constant) callees :test 'equal)) + ;; Return nil so we iterate over all constants. + nil)) + callees)) + +;; only for lispworks 4.2 and above +#-lispworks4.1 +(progn + (defxref who-references hcl:who-references) + (defxref who-binds hcl:who-binds) + (defxref who-sets hcl:who-sets)) + +(defimplementation who-specializes (classname) + (let ((methods (clos:class-direct-methods (find-class classname)))) + (xref-results (mapcar #'dspec:object-dspec methods)))) + +(defun xref-results (dspecs) + (flet ((frob-locs (dspec locs) + (cond (locs + (loop for (name loc) in locs + collect (list name (make-dspec-location name loc)))) + (t `((,dspec (:error "Source location not available"))))))) + (loop for dspec in dspecs + append (frob-locs dspec (dspec:dspec-definition-locations dspec))))) + +;;; Inspector + +(defmethod emacs-inspect ((o t)) + (lispworks-inspect o)) + +(defmethod emacs-inspect ((o function)) + (lispworks-inspect o)) + +;; FIXME: slot-boundp-using-class in LW works with names so we can't +;; use our method in swank.lisp. +(defmethod emacs-inspect ((o standard-object)) + (lispworks-inspect o)) + +(defun lispworks-inspect (o) + (multiple-value-bind (names values _getter _setter type) + (lw:get-inspector-values o nil) + (declare (ignore _getter _setter)) + (append + (label-value-line "Type" type) + (loop for name in names + for value in values + append (label-value-line name value))))) + +;;; Miscellaneous + +(defimplementation quit-lisp () + (lispworks:quit)) + +;;; Tracing + +(defun parse-fspec (fspec) + "Return a dspec for FSPEC." + (ecase (car fspec) + ((:defmethod) `(method ,(cdr fspec))))) + +(defun tracedp (dspec) + (member dspec (eval '(trace)) :test #'equal)) + +(defun toggle-trace-aux (dspec) + (cond ((tracedp dspec) + (eval `(untrace ,dspec)) + (format nil "~S is now untraced." dspec)) + (t + (eval `(trace (,dspec))) + (format nil "~S is now traced." dspec)))) + +(defimplementation toggle-trace (fspec) + (toggle-trace-aux (parse-fspec fspec))) + +;;; Multithreading + +(defimplementation initialize-multiprocessing (continuation) + (cond ((not mp::*multiprocessing*) + (push (list "Initialize SLIME" '() continuation) + mp:*initial-processes*) + (mp:initialize-multiprocessing)) + (t (funcall continuation)))) + +(defimplementation spawn (fn &key name) + (mp:process-run-function name () fn)) + +(defvar *id-lock* (mp:make-lock)) +(defvar *thread-id-counter* 0) + +(defimplementation thread-id (thread) + (mp:with-lock (*id-lock*) + (or (getf (mp:process-plist thread) 'id) + (setf (getf (mp:process-plist thread) 'id) + (incf *thread-id-counter*))))) + +(defimplementation find-thread (id) + (find id (mp:list-all-processes) + :key (lambda (p) (getf (mp:process-plist p) 'id)))) + +(defimplementation thread-name (thread) + (mp:process-name thread)) + +(defimplementation thread-status (thread) + (format nil "~A ~D" + (mp:process-whostate thread) + (mp:process-priority thread))) + +(defimplementation make-lock (&key name) + (mp:make-lock :name name)) + +(defimplementation call-with-lock-held (lock function) + (mp:with-lock (lock) (funcall function))) + +(defimplementation current-thread () + mp:*current-process*) + +(defimplementation all-threads () + (mp:list-all-processes)) + +(defimplementation interrupt-thread (thread fn) + (mp:process-interrupt thread fn)) + +(defimplementation kill-thread (thread) + (mp:process-kill thread)) + +(defimplementation thread-alive-p (thread) + (mp:process-alive-p thread)) + +(defstruct (mailbox (:conc-name mailbox.)) + (mutex (mp:make-lock :name "thread mailbox")) + (queue '() :type list)) + +(defvar *mailbox-lock* (mp:make-lock)) + +(defun mailbox (thread) + (mp:with-lock (*mailbox-lock*) + (or (getf (mp:process-plist thread) 'mailbox) + (setf (getf (mp:process-plist thread) 'mailbox) + (make-mailbox))))) + +(defimplementation receive-if (test &optional timeout) + (let* ((mbox (mailbox mp:*current-process*)) + (lock (mailbox.mutex mbox))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (mp:with-lock (lock "receive-if/try") + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail))))) + (when (eq timeout t) (return (values nil t))) + (mp:process-wait-with-timeout + "receive-if" 0.3 (lambda () (some test (mailbox.queue mbox))))))) + +(defimplementation send (thread message) + (let ((mbox (mailbox thread))) + (mp:with-lock ((mailbox.mutex mbox)) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message)))))) + +(let ((alist '()) + (lock (mp:make-lock :name "register-thread"))) + + (defimplementation register-thread (name thread) + (declare (type symbol name)) + (mp:with-lock (lock) + (etypecase thread + (null + (setf alist (delete name alist :key #'car))) + (mp:process + (let ((probe (assoc name alist))) + (cond (probe (setf (cdr probe) thread)) + (t (setf alist (acons name thread alist)))))))) + nil) + + (defimplementation find-registered (name) + (mp:with-lock (lock) + (cdr (assoc name alist))))) + + +(defimplementation set-default-initial-binding (var form) + (setq mp:*process-initial-bindings* + (acons var `(eval (quote ,form)) + mp:*process-initial-bindings* ))) + +(defimplementation thread-attributes (thread) + (list :priority (mp:process-priority thread) + :idle (mp:process-idle-time thread))) + + +;;;; Weak hashtables + +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak-kind :key args)) + +(defimplementation make-weak-value-hash-table (&rest args) + (apply #'make-hash-table :weak-kind :value args)) diff --git a/vim/bundle/slimv/slime/swank/match.lisp b/vim/bundle/slimv/slime/swank/match.lisp new file mode 100644 index 0000000..d6200db --- /dev/null +++ b/vim/bundle/slimv/slime/swank/match.lisp @@ -0,0 +1,242 @@ +;; +;; SELECT-MATCH macro (and IN macro) +;; +;; Copyright 1990 Stephen Adams +;; +;; You are free to copy, distribute and make derivative works of this +;; source provided that this copyright notice is displayed near the +;; beginning of the file. No liability is accepted for the +;; correctness or performance of the code. If you modify the code +;; please indicate this fact both at the place of modification and in +;; this copyright message. +;; +;; Stephen Adams +;; Department of Electronics and Computer Science +;; University of Southampton +;; SO9 5NH, UK +;; +;; sra@ecs.soton.ac.uk +;; + +;; +;; Synopsis: +;; +;; (select-match expression +;; (pattern action+)*) +;; +;; --- or --- +;; +;; (select-match expression +;; pattern => expression +;; pattern => expression +;; ...) +;; +;; pattern -> constant ;egs 1, #\x, #c(1.0 1.1) +;; | symbol ;matches anything +;; | 'anything ;must be EQUAL +;; | (pattern = pattern) ;both patterns must match +;; | (#'function pattern) ;predicate test +;; | (pattern . pattern) ;cons cell +;; + +;; Example +;; +;; (select-match item +;; (('if e1 e2 e3) 'if-then-else) ;(1) +;; ((#'oddp k) 'an-odd-integer) ;(2) +;; (((#'treep tree) = (hd . tl)) 'something-else) ;(3) +;; (other 'anything-else)) ;(4) +;; +;; Notes +;; +;; . Each pattern is tested in turn. The first match is taken. +;; +;; . If no pattern matches, an error is signalled. +;; +;; . Constant patterns (things X for which (CONSTANTP X) is true, i.e. +;; numbers, strings, characters, etc.) match things which are EQUAL. +;; +;; . Quoted patterns (which are CONSTANTP) are constants. +;; +;; . Symbols match anything. The symbol is bound to the matched item +;; for the execution of the actions. +;; For example, (SELECT-MATCH '(1 2 3) +;; (1 . X) => X) +;; returns (2 3) because X is bound to the cdr of the candidate. +;; +;; . The two pattern match (p1 = p2) can be used to name parts +;; of the matched structure. For example, (ALL = (HD . TL)) +;; matches a cons cell. ALL is bound to the cons cell, HD to its car +;; and TL to its tail. +;; +;; . A predicate test applies the predicate to the item being matched. +;; If the predicate returns NIL then the match fails. +;; If it returns truth, then the nested pattern is matched. This is +;; often just a symbol like K in the example. +;; +;; . Care should be taken with the domain values for predicate matches. +;; If, in the above eg, item is not an integer, an error would occur +;; during the test. A safer pattern would be +;; (#'integerp (#'oddp k)) +;; This would only test for oddness of the item was an integer. +;; +;; . A single symbol will match anything so it can be used as a default +;; case, like OTHER above. +;; + +(in-package swank/match) + +(defmacro match (expression &body patterns) + `(select-match ,expression ,@patterns)) + +(defmacro select-match (expression &rest patterns) + (let* ((do-let (not (atom expression))) + (key (if do-let (gensym) expression)) + (cbody (expand-select-patterns key patterns)) + (cform `(cond . ,cbody))) + (if do-let + `(let ((,key ,expression)) ,cform) + cform))) + +(defun expand-select-patterns (key patterns) + (if (eq (second patterns) '=>) + (expand-select-patterns-style-2 key patterns) + (expand-select-patterns-style-1 key patterns))) + +(defun expand-select-patterns-style-1 (key patterns) + (if (null patterns) + `((t (error "Case select pattern match failure on ~S" ,key))) + (let* ((pattern (caar patterns)) + (actions (cdar patterns)) + (rest (cdr patterns)) + (test (compile-select-test key pattern)) + (bindings (compile-select-bindings key pattern actions))) + `(,(if bindings `(,test (let ,bindings . ,actions)) + `(,test . ,actions)) + . ,(unless (eq test t) + (expand-select-patterns-style-1 key rest)))))) + +(defun expand-select-patterns-style-2 (key patterns) + (cond ((null patterns) + `((t (error "Case select pattern match failure on ~S" ,key)))) + (t (when (or (< (length patterns) 3) + (not (eq (second patterns) '=>))) + (error "Illegal patterns: ~S" patterns)) + (let* ((pattern (first patterns)) + (actions (list (third patterns))) + (rest (cdddr patterns)) + (test (compile-select-test key pattern)) + (bindings (compile-select-bindings key pattern actions))) + `(,(if bindings `(,test (let ,bindings . ,actions)) + `(,test . ,actions)) + . ,(unless (eq test t) + (expand-select-patterns-style-2 key rest))))))) + +(defun compile-select-test (key pattern) + (let ((tests (remove t (compile-select-tests key pattern)))) + (cond + ;; note AND does this anyway, but this allows us to tell if + ;; the pattern will always match. + ((null tests) t) + ((= (length tests) 1) (car tests)) + (t `(and . ,tests))))) + +(defun compile-select-tests (key pattern) + (cond ((constantp pattern) `((,(cond ((numberp pattern) 'eql) + ((symbolp pattern) 'eq) + (t 'equal)) + ,key ,pattern))) + ((symbolp pattern) '(t)) + ((select-double-match? pattern) + (append + (compile-select-tests key (first pattern)) + (compile-select-tests key (third pattern)))) + ((select-predicate? pattern) + (append + `((,(second (first pattern)) ,key)) + (compile-select-tests key (second pattern)))) + ((consp pattern) + (append + `((consp ,key)) + (compile-select-tests (cs-car key) (car + pattern)) + (compile-select-tests (cs-cdr key) (cdr + pattern)))) + (t (error "Illegal select pattern: ~S" pattern)))) + + +(defun compile-select-bindings (key pattern action) + (cond ((constantp pattern) '()) + ((symbolp pattern) + (if (select-in-tree pattern action) + `((,pattern ,key)) + '())) + ((select-double-match? pattern) + (append + (compile-select-bindings key (first pattern) action) + (compile-select-bindings key (third pattern) action))) + ((select-predicate? pattern) + (compile-select-bindings key (second pattern) action)) + ((consp pattern) + (append + (compile-select-bindings (cs-car key) (car pattern) + action) + (compile-select-bindings (cs-cdr key) (cdr pattern) + action))))) + +(defun select-in-tree (atom tree) + (or (eq atom tree) + (if (consp tree) + (or (select-in-tree atom (car tree)) + (select-in-tree atom (cdr tree)))))) + +(defun select-double-match? (pattern) + ;; (<pattern> = <pattern>) + (and (consp pattern) (consp (cdr pattern)) (consp (cddr pattern)) + (null (cdddr pattern)) + (eq (second pattern) '=))) + +(defun select-predicate? (pattern) + ;; ((function <f>) <pattern>) + (and (consp pattern) + (consp (cdr pattern)) + (null (cddr pattern)) + (consp (first pattern)) + (consp (cdr (first pattern))) + (null (cddr (first pattern))) + (eq (caar pattern) 'function))) + +(defun cs-car (exp) + (cs-car/cdr 'car exp + '((car . caar) (cdr . cadr) (caar . caaar) (cadr . caadr) + (cdar . cadar) (cddr . caddr) + (caaar . caaaar) (caadr . caaadr) (cadar . caadar) + (caddr . caaddr) (cdaar . cadaar) (cdadr . cadadr) + (cddar . caddar) (cdddr . cadddr)))) + +(defun cs-cdr (exp) + (cs-car/cdr 'cdr exp + '((car . cdar) (cdr . cddr) (caar . cdaar) (cadr . cdadr) + (cdar . cddar) (cddr . cdddr) + (caaar . cdaaar) (caadr . cdaadr) (cadar . cdadar) + (caddr . cdaddr) (cdaar . cddaar) (cdadr . cddadr) + (cddar . cdddar) (cdddr . cddddr)))) + +(defun cs-car/cdr (op exp table) + (if (and (consp exp) (= (length exp) 2)) + (let ((replacement (assoc (car exp) table))) + (if replacement + `(,(cdr replacement) ,(second exp)) + `(,op ,exp))) + `(,op ,exp))) + +;; (setf c1 '(select-match x (a 1) (b 2 3 4))) +;; (setf c2 '(select-match (car y) +;; (1 (print 100) 101) (2 200) ("hello" 5) (:x 20) (else (1+ +;; else)))) +;; (setf c3 '(select-match (caddr y) +;; ((all = (x y)) (list x y all)) +;; ((a '= b) (list 'assign a b)) +;; ((#'oddp k) (1+ k))))) + + diff --git a/vim/bundle/slimv/slime/swank/mkcl.lisp b/vim/bundle/slimv/slime/swank/mkcl.lisp new file mode 100644 index 0000000..53696fb --- /dev/null +++ b/vim/bundle/slimv/slime/swank/mkcl.lisp @@ -0,0 +1,933 @@ +;;;; -*- indent-tabs-mode: nil -*- +;;; +;;; swank-mkcl.lisp --- SLIME backend for MKCL. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +;;; Administrivia + +(defpackage swank/mkcl + (:use cl swank/backend)) + +(in-package swank/mkcl) + +;;(declaim (optimize (debug 3))) + +(defvar *tmp*) + +(defimplementation gray-package-name () + '#:gray) + +(eval-when (:compile-toplevel :load-toplevel) + + (swank/backend::import-swank-mop-symbols :clos + ;; '(:eql-specializer + ;; :eql-specializer-object + ;; :generic-function-declarations + ;; :specializer-direct-methods + ;; :compute-applicable-methods-using-classes) + nil + )) + + +;;; UTF8 + +(defimplementation string-to-utf8 (string) + (mkcl:octets (si:utf-8 string))) + +(defimplementation utf8-to-string (octets) + (string (si:utf-8 octets))) + + +;;;; TCP Server + +(eval-when (:compile-toplevel :load-toplevel) + ;; At compile-time we need access to the sb-bsd-sockets package for the + ;; the following code to be read properly. + ;; It is a bit a shame we have to load the entire module to get that. + (require 'sockets)) + + +(defun resolve-hostname (name) + (car (sb-bsd-sockets:host-ent-addresses + (sb-bsd-sockets:get-host-by-name name)))) + +(defimplementation create-socket (host port &key backlog) + (let ((socket (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) + (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port) + (sb-bsd-sockets:socket-listen socket (or backlog 5)) + socket)) + +(defimplementation local-port (socket) + (nth-value 1 (sb-bsd-sockets:socket-name socket))) + +(defimplementation close-socket (socket) + (sb-bsd-sockets:socket-close socket)) + +(defun accept (socket) + "Like socket-accept, but retry on EINTR." + (loop (handler-case + (return (sb-bsd-sockets:socket-accept socket)) + (sb-bsd-sockets:interrupted-error ())))) + +(defimplementation accept-connection (socket + &key external-format + buffering timeout) + (declare (ignore timeout)) + (sb-bsd-sockets:socket-make-stream (accept socket) + :output t ;; bogus + :input t ;; bogus + :buffering buffering ;; bogus + :element-type (if external-format + 'character + '(unsigned-byte 8)) + :external-format external-format + )) + +(defimplementation preferred-communication-style () + :spawn + ) + +(defvar *external-format-to-coding-system* + '((:iso-8859-1 + "latin-1" "latin-1-unix" "iso-latin-1-unix" + "iso-8859-1" "iso-8859-1-unix") + (:utf-8 "utf-8" "utf-8-unix"))) + +(defun external-format (coding-system) + (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*)) + (find coding-system (si:all-encodings) :test #'string-equal))) + +(defimplementation find-external-format (coding-system) + #+unicode (external-format coding-system) + ;; Without unicode support, MKCL uses the one-byte encoding of the + ;; underlying OS, and will barf on anything except :DEFAULT. We + ;; return NIL here for known multibyte encodings, so + ;; SWANK:CREATE-SERVER will barf. + #-unicode (let ((xf (external-format coding-system))) + (if (member xf '(:utf-8)) + nil + :default))) + + + +;;;; Unix signals + +(defimplementation install-sigint-handler (handler) + (let ((old-handler (symbol-function 'si:terminal-interrupt))) + (setf (symbol-function 'si:terminal-interrupt) + (if (consp handler) + (car handler) + (lambda (&rest args) + (declare (ignore args)) + (funcall handler) + (continue)))) + (list old-handler))) + + +(defimplementation getpid () + (mkcl:getpid)) + +(defimplementation set-default-directory (directory) + (mk-ext::chdir (namestring directory)) + (default-directory)) + +(defimplementation default-directory () + (namestring (mk-ext:getcwd))) + +(defmacro progf (plist &rest forms) + `(let (_vars _vals) + (do ((p ,plist (cddr p))) + ((endp p)) + (push (car p) _vars) + (push (cadr p) _vals)) + (progv _vars _vals ,@forms) + ) + ) + +(defvar *inferior-lisp-sleeping-post* nil) + +(defimplementation quit-lisp () + (progf (ignore-errors (eval (read-from-string "swank::*saved-global-streams*"))) ;; restore original IO streams. + (when *inferior-lisp-sleeping-post* (mt:semaphore-signal *inferior-lisp-sleeping-post*)) + ;;(mk-ext:quit :verbose t) + )) + + +;;;; Compilation + +(defvar *buffer-name* nil) +(defvar *buffer-start-position*) +(defvar *buffer-string*) +(defvar *compile-filename*) + +(defun signal-compiler-condition (&rest args) + (signal (apply #'make-condition 'compiler-condition args))) + +#| +(defun handle-compiler-warning (condition) + (signal-compiler-condition + :original-condition condition + :message (format nil "~A" condition) + :severity :warning + :location + (if *buffer-name* + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-start-position* 0)) + ;; ;; compiler::*current-form* + ;; (if compiler::*current-function* + ;; (make-location (list :file *compile-filename*) + ;; (list :function-name + ;; (symbol-name + ;; (slot-value compiler::*current-function* + ;; 'compiler::name)))) + (list :error "No location found.") + ;; ) + ))) +|# + +#| +(defun condition-location (condition) + (let ((file (compiler:compiler-message-file condition)) + (position (compiler:compiler-message-file-position condition))) + (if (and position (not (minusp position))) + (if *buffer-name* + (make-buffer-location *buffer-name* + *buffer-start-position* + position) + (make-file-location file position)) + (make-error-location "No location found.")))) +|# + +(defun condition-location (condition) + (if *buffer-name* + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-start-position* 0)) + ;; ;; compiler::*current-form* ; + ;; (if compiler::*current-function* ; + ;; (make-location (list :file *compile-filename*) ; + ;; (list :function-name ; + ;; (symbol-name ; + ;; (slot-value compiler::*current-function* ; + ;; 'compiler::name)))) ; + (if (typep condition 'compiler::compiler-message) + (make-location (list :file (namestring (compiler:compiler-message-file condition))) + (list :end-position (compiler:compiler-message-file-end-position condition))) + (list :error "No location found.")) + ) + ) + +(defun handle-compiler-message (condition) + (unless (typep condition 'compiler::compiler-note) + (signal-compiler-condition + :original-condition condition + :message (princ-to-string condition) + :severity (etypecase condition + (compiler:compiler-fatal-error :error) + (compiler:compiler-error :error) + (error :error) + (style-warning :style-warning) + (warning :warning)) + :location (condition-location condition)))) + +(defimplementation call-with-compilation-hooks (function) + (handler-bind ((compiler:compiler-message #'handle-compiler-message)) + (funcall function))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (with-compilation-hooks () + (let ((*buffer-name* nil) + (*compile-filename* input-file)) + (handler-bind (#| + (compiler::compiler-note + #'(lambda (n) + (format t "~%swank saw a compiler note: ~A~%" n) (finish-output) nil)) + (compiler::compiler-warning + #'(lambda (w) + (format t "~%swank saw a compiler warning: ~A~%" w) (finish-output) nil)) + (compiler::compiler-error + #'(lambda (e) + (format t "~%swank saw a compiler error: ~A~%" e) (finish-output) nil)) + |# + ) + (multiple-value-bind (output-truename warnings-p failure-p) + (compile-file input-file :output-file output-file :external-format external-format) + (values output-truename warnings-p + (or failure-p + (and load-p (not (load output-truename)))))))))) + +(defimplementation swank-compile-string (string &key buffer position filename policy) + (declare (ignore filename policy)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-start-position* position) + (*buffer-string* string)) + (with-input-from-string (s string) + (when position (file-position position)) + (compile-from-stream s))))) + +(defun compile-from-stream (stream) + (let ((file (mkcl:mkstemp "TMP:MKCL-SWANK-TMPXXXXXX")) + output-truename + warnings-p + failure-p + ) + (with-open-file (s file :direction :output :if-exists :overwrite) + (do ((line (read-line stream nil) (read-line stream nil))) + ((not line)) + (write-line line s))) + (unwind-protect + (progn + (multiple-value-setq (output-truename warnings-p failure-p) + (compile-file file)) + (and (not failure-p) (load output-truename))) + (when (probe-file file) (delete-file file)) + (when (probe-file output-truename) (delete-file output-truename))))) + + +;;;; Documentation + +(defun grovel-docstring-for-arglist (name type) + (flet ((compute-arglist-offset (docstring) + (when docstring + (let ((pos1 (search "Args: " docstring))) + (if pos1 + (+ pos1 6) + (let ((pos2 (search "Syntax: " docstring))) + (when pos2 + (+ pos2 8)))))))) + (let* ((docstring (si::get-documentation name type)) + (pos (compute-arglist-offset docstring))) + (if pos + (multiple-value-bind (arglist errorp) + (ignore-errors + (values (read-from-string docstring t nil :start pos))) + (if (or errorp (not (listp arglist))) + :not-available + arglist + )) + :not-available )))) + +(defimplementation arglist (name) + (cond ((and (symbolp name) (special-operator-p name)) + (let ((arglist (grovel-docstring-for-arglist name 'function))) + (if (consp arglist) (cdr arglist) arglist))) + ((and (symbolp name) (macro-function name)) + (let ((arglist (grovel-docstring-for-arglist name 'function))) + (if (consp arglist) (cdr arglist) arglist))) + ((or (functionp name) (fboundp name)) + (multiple-value-bind (name fndef) + (if (functionp name) + (values (function-name name) name) + (values name (fdefinition name))) + (let ((fle (function-lambda-expression fndef))) + (case (car fle) + (si:lambda-block (caddr fle)) + (t (typecase fndef + (generic-function (clos::generic-function-lambda-list fndef)) + (compiled-function (grovel-docstring-for-arglist name 'function)) + (function :not-available))))))) + (t :not-available))) + +(defimplementation function-name (f) + (si:compiled-function-name f) + ) + +(eval-when (:compile-toplevel :load-toplevel) + ;; At compile-time we need access to the walker package for the + ;; the following code to be read properly. + ;; It is a bit a shame we have to load the entire module to get that. + (require 'walker)) + +(defimplementation macroexpand-all (form &optional env) + (declare (ignore env)) + (walker:macroexpand-all form)) + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (dolist (type '(:VARIABLE :FUNCTION :CLASS)) + (let ((doc (describe-definition symbol type))) + (when doc + (setf result (list* type doc result))))) + result)) + +(defimplementation describe-definition (name type) + (case type + (:variable (documentation name 'variable)) + (:function (documentation name 'function)) + (:class (documentation name 'class)) + (t nil))) + +;;; Debugging + +(eval-when (:compile-toplevel :load-toplevel) + (import + '(si::*break-env* + si::*ihs-top* + si::*ihs-current* + si::*ihs-base* + si::*frs-base* + si::*frs-top* + si::*tpl-commands* + si::*tpl-level* + si::frs-top + si::ihs-top + si::ihs-fun + si::ihs-env + si::sch-frs-base + si::set-break-env + si::set-current-ihs + si::tpl-commands))) + +(defvar *backtrace* '()) + +(defun in-swank-package-p (x) + (and + (symbolp x) + (member (symbol-package x) + (list #.(find-package :swank) + #.(find-package :swank/backend) + #.(ignore-errors (find-package :swank-mop)) + #.(ignore-errors (find-package :swank-loader)))) + t)) + +(defun is-swank-source-p (name) + (setf name (pathname name)) + #+(or) + (pathname-match-p + name + (make-pathname :defaults swank-loader::*source-directory* + :name (pathname-name name) + :type (pathname-type name) + :version (pathname-version name))) + nil) + +(defun is-ignorable-fun-p (x) + (or + (in-swank-package-p (frame-name x)) + (multiple-value-bind (file position) + (ignore-errors (si::compiled-function-file (car x))) + (declare (ignore position)) + (if file (is-swank-source-p file))))) + +(defmacro find-ihs-top (x) + (declare (ignore x)) + '(si::ihs-top)) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (declare (type function debugger-loop-fn)) + (let* (;;(*tpl-commands* si::tpl-commands) + (*ihs-base* 0) + (*ihs-top* (find-ihs-top 'call-with-debugging-environment)) + (*ihs-current* *ihs-top*) + (*frs-base* (or (sch-frs-base 0 #|*frs-top*|# *ihs-base*) (1+ (frs-top)))) + (*frs-top* (frs-top)) + (*read-suppress* nil) + ;;(*tpl-level* (1+ *tpl-level*)) + (*backtrace* (loop for ihs from 0 below *ihs-top* + collect (list (si::ihs-fun ihs) + (si::ihs-env ihs) + nil)))) + (declare (special *ihs-current*)) + (loop for f from *frs-base* to *frs-top* + do (let ((i (- (si::frs-ihs f) *ihs-base* 1))) + (when (plusp i) + (let* ((x (elt *backtrace* i)) + (name (si::frs-tag f))) + (unless (mkcl:fixnump name) + (push name (third x))))))) + (setf *backtrace* (remove-if #'is-ignorable-fun-p (nreverse *backtrace*))) + (setf *tmp* *backtrace*) + (set-break-env) + (set-current-ihs) + (let ((*ihs-base* *ihs-top*)) + (funcall debugger-loop-fn)))) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook) + (*ihs-base* (find-ihs-top 'call-with-debugger-hook))) + (funcall fun))) + +(defimplementation compute-backtrace (start end) + (when (numberp end) + (setf end (min end (length *backtrace*)))) + (loop for f in (subseq *backtrace* start end) + collect f)) + +(defimplementation format-sldb-condition (condition) + "Format a condition for display in SLDB." + ;;(princ-to-string condition) + (format nil "~A~%In thread: ~S" condition mt:*thread*) + ) + +(defun frame-name (frame) + (let ((x (first frame))) + (if (symbolp x) + x + (function-name x)))) + +(defun function-position (fun) + (multiple-value-bind (file position) + (si::compiled-function-file fun) + (and file (make-location + `(:file ,(if (stringp file) file (namestring file))) + ;;`(:position ,position) + `(:end-position , position))))) + +(defun frame-function (frame) + (let* ((x (first frame)) + fun position) + (etypecase x + (symbol (and (fboundp x) + (setf fun (fdefinition x) + position (function-position fun)))) + (function (setf fun x position (function-position x)))) + (values fun position))) + +(defun frame-decode-env (frame) + (let ((functions '()) + (blocks '()) + (variables '())) + (setf frame (si::decode-ihs-env (second frame))) + (dolist (record frame) + (let* ((record0 (car record)) + (record1 (cdr record))) + (cond ((or (symbolp record0) (stringp record0)) + (setq variables (acons record0 record1 variables))) + ((not (mkcl:fixnump record0)) + (push record1 functions)) + ((symbolp record1) + (push record1 blocks)) + (t + )))) + (values functions blocks variables))) + +(defimplementation print-frame (frame stream) + (let ((function (first frame))) + (let ((fname +;;; (cond ((symbolp function) function) +;;; ((si:instancep function) (slot-value function 'name)) +;;; ((compiled-function-p function) +;;; (or (si::compiled-function-name function) 'lambda)) +;;; (t :zombi)) + (si::get-fname function) + )) + (if (eq fname 'si::bytecode) + (format stream "~A [Evaluation of: ~S]" + fname (function-lambda-expression function)) + (format stream "~A" fname) + ) + (when (si::closurep function) + (format stream + ", closure generated from ~A" + (si::get-fname (si:closure-producer function))) + ) + ) + ) + ) + +(defimplementation frame-source-location (frame-number) + (nth-value 1 (frame-function (elt *backtrace* frame-number)))) + +(defimplementation frame-catch-tags (frame-number) + (third (elt *backtrace* frame-number))) + +(defimplementation frame-locals (frame-number) + (loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number))) + with i = 0 + collect (list :name name :id (prog1 i (incf i)) :value value))) + +(defimplementation frame-var-value (frame-number var-id) + (cdr (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number))) var-id))) + +(defimplementation disassemble-frame (frame-number) + (let ((fun (frame-fun (elt *backtrace* frame-number)))) + (disassemble fun))) + +(defimplementation eval-in-frame (form frame-number) + (let ((env (second (elt *backtrace* frame-number)))) + (si:eval-in-env form env))) + +#| +(defimplementation gdb-initial-commands () + ;; These signals are used by the GC. + #+linux '("handle SIGPWR noprint nostop" + "handle SIGXCPU noprint nostop")) + +(defimplementation command-line-args () + (loop for n from 0 below (si:argc) collect (si:argv n))) +|# + +;;;; Inspector + +(defmethod emacs-inspect ((o t)) + ; ecl clos support leaves some to be desired + (cond + ((streamp o) + (list* + (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))))))) + ((si:instancep o) ;;t + (let* ((cl (si:instance-class o)) + (slots (clos::class-slots cl))) + (list* (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 (if (slot-boundp o name) + (clos::slot-value o name) + "Unbound" + ))) + (list + (format nil "~S: " name) + `(:value ,value) + `(:newline))))))) + (t (list (format nil "~A" o))))) + +;;;; Definitions + +(defimplementation find-definitions (name) + (if (fboundp name) + (let ((tmp (find-source-location (symbol-function name)))) + `(((defun ,name) ,tmp))))) + +(defimplementation find-source-location (obj) + (setf *tmp* obj) + (or + (typecase obj + (function + (multiple-value-bind (file pos) (ignore-errors (si::compiled-function-file obj)) + (if (and file pos) + (make-location + `(:file ,(if (stringp file) file (namestring file))) + `(:end-position ,pos) ;; `(:position ,pos) + `(:snippet + ,(with-open-file (s file) + (file-position s pos) + (skip-comments-and-whitespace s) + (read-snippet s)))))))) + `(:error (format nil "Source definition of ~S not found" obj)))) + +;;;; Profiling + + +(eval-when (:compile-toplevel :load-toplevel) + ;; At compile-time we need access to the profile package for the + ;; the following code to be read properly. + ;; It is a bit a shame we have to load the entire module to get that. + (require 'profile)) + + +(defimplementation profile (fname) + (when fname (eval `(profile:profile ,fname)))) + +(defimplementation unprofile (fname) + (when fname (eval `(profile:unprofile ,fname)))) + +(defimplementation unprofile-all () + (profile:unprofile-all) + "All functions unprofiled.") + +(defimplementation profile-report () + (profile:report)) + +(defimplementation profile-reset () + (profile:reset) + "Reset profiling counters.") + +(defimplementation profiled-functions () + (profile:profile)) + +(defimplementation profile-package (package callers methods) + (declare (ignore callers methods)) + (eval `(profile:profile ,(package-name (find-package package))))) + + +;;;; Threads + +(defvar *thread-id-counter* 0) + +(defvar *thread-id-counter-lock* + (mt:make-lock :name "thread id counter lock")) + +(defun next-thread-id () + (mt:with-lock (*thread-id-counter-lock*) + (incf *thread-id-counter*)) + ) + +(defparameter *thread-id-map* (make-hash-table)) +(defparameter *id-thread-map* (make-hash-table)) + +(defvar *thread-id-map-lock* + (mt:make-lock :name "thread id map lock")) + +(defparameter +default-thread-local-variables+ + '(*macroexpand-hook* + *default-pathname-defaults* + *readtable* + *random-state* + *compile-print* + *compile-verbose* + *load-print* + *load-verbose* + *print-array* + *print-base* + *print-case* + *print-circle* + *print-escape* + *print-gensym* + *print-length* + *print-level* + *print-lines* + *print-miser-width* + *print-pprint-dispatch* + *print-pretty* + *print-radix* + *print-readably* + *print-right-margin* + *read-base* + *read-default-float-format* + *read-eval* + *read-suppress* + )) + +(defun thread-local-default-bindings () + (let (local) + (dolist (var +default-thread-local-variables+ local) + (setq local (acons var (symbol-value var) local)) + ))) + +;; mkcl doesn't have weak pointers +(defimplementation spawn (fn &key name initial-bindings) + (let* ((local-defaults (thread-local-default-bindings)) + (thread + ;;(mt:make-thread :name name) + (mt:make-thread :name name + :initial-bindings (nconc initial-bindings + local-defaults)) + ) + (id (next-thread-id))) + (mt:with-lock (*thread-id-map-lock*) + (setf (gethash id *thread-id-map*) thread) + (setf (gethash thread *id-thread-map*) id)) + (mt:thread-preset + thread + #'(lambda () + (unwind-protect + (progn + ;;(format t "~&Starting thread: ~S.~%" name) (finish-output) + (mt:thread-detach nil) + (funcall fn)) + (progn + ;;(format t "~&Wrapping up thread: ~S.~%" name) (finish-output) + (mt:with-lock (*thread-id-map-lock*) + (remhash thread *id-thread-map*) + (remhash id *thread-id-map*)) + ;;(format t "~&Finished thread: ~S~%" name) (finish-output) + )))) + (mt:thread-enable thread) + (mt:thread-yield) + thread + )) + +(defimplementation thread-id (thread) + (block thread-id + (mt:with-lock (*thread-id-map-lock*) + (or (gethash thread *id-thread-map*) + (let ((id (next-thread-id))) + (setf (gethash id *thread-id-map*) thread) + (setf (gethash thread *id-thread-map*) id) + id))))) + +(defimplementation find-thread (id) + (mt:with-lock (*thread-id-map-lock*) + (gethash id *thread-id-map*))) + +(defimplementation thread-name (thread) + (mt:thread-name thread)) + +(defimplementation thread-status (thread) + (if (mt:thread-active-p thread) + "RUNNING" + "STOPPED")) + +(defimplementation make-lock (&key name) + (mt:make-lock :name name :recursive t)) + +(defimplementation call-with-lock-held (lock function) + (declare (type function function)) + (mt:with-lock (lock) (funcall function))) + +(defimplementation current-thread () + mt:*thread*) + +(defimplementation all-threads () + (mt:all-threads)) + +(defimplementation interrupt-thread (thread fn) + (mt:interrupt-thread thread fn)) + +(defimplementation kill-thread (thread) + (mt:interrupt-thread thread #'mt:terminate-thread) + ) + +(defimplementation thread-alive-p (thread) + (mt:thread-active-p thread)) + +(defvar *mailbox-lock* (mt:make-lock :name "mailbox lock")) +(defvar *mailboxes* (list)) +(declaim (type list *mailboxes*)) + +(defstruct (mailbox (:conc-name mailbox.)) + thread + locked-by + (mutex (mt:make-lock :name "thread mailbox")) + (semaphore (mt:make-semaphore)) + (queue '() :type list)) + +(defun mailbox (thread) + "Return THREAD's mailbox." + (mt: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) + (handler-case + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) +;; (mt:interrupt-thread +;; thread +;; (lambda () +;; (mt:with-lock (mutex) +;; (setf (mailbox.queue mbox) +;; (nconc (mailbox.queue mbox) (list message)))))) + +;; (format t "~&! thread = ~S~% thread = ~S~% message = ~S~%" +;; mt:*thread* thread message) (finish-output) + (mt:with-lock (mutex) + (setf (mailbox.locked-by mbox) mt:*thread*) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + ;;(format t "*") (finish-output) + (handler-case + (mt:semaphore-signal (mailbox.semaphore mbox)) + (condition (condition) + (format t "Something went bad with semaphore-signal ~A" condition) (finish-output) + ;;(break) + )) + (setf (mailbox.locked-by mbox) nil) + ) + ;;(format t "+") (finish-output) + ) + (condition (condition) + (format t "~&Error in send: ~S~%" condition) (finish-output)) + ) + ) + +;; (defimplementation receive () +;; (block got-mail +;; (let* ((mbox (mailbox mt:*thread*)) +;; (mutex (mailbox.mutex mbox))) +;; (loop +;; (mt:with-lock (mutex) +;; (if (mailbox.queue mbox) +;; (return-from got-mail (pop (mailbox.queue mbox))))) +;; ;;interrupt-thread will halt this if it takes longer than 1sec +;; (sleep 1))))) + + +(defimplementation receive-if (test &optional timeout) + (handler-case + (let* ((mbox (mailbox (current-thread))) + (mutex (mailbox.mutex mbox)) + got-one) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + ;;(format t "~&: ~S~%" mt:*thread*) (finish-output) + (handler-case + (setq got-one (mt:semaphore-wait (mailbox.semaphore mbox) 2)) + (condition (condition) + (format t "~&In (swank-mkcl) receive-if: Something went bad with semaphore-wait ~A~%" condition) + (finish-output) + nil + ) + ) + (mt:with-lock (mutex) + (setf (mailbox.locked-by mbox) mt:*thread*) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (setf (mailbox.locked-by mbox) nil) + ;;(format t "~&thread ~S received: ~S~%" mt:*thread* (car tail)) + (return (car tail)))) + (setf (mailbox.locked-by mbox) nil) + ) + + ;;(format t "/ ~S~%" mt:*thread*) (finish-output) + (when (eq timeout t) (return (values nil t))) +;; (unless got-one +;; (format t "~&In (swank-mkcl) receive-if: semaphore-wait timed out!~%")) + ) + ) + (condition (condition) + (format t "~&Error in (swank-mkcl) receive-if: ~S, ~A~%" condition condition) (finish-output) + nil + ) + ) + ) + + +(defmethod stream-finish-output ((stream stream)) + (finish-output stream)) + + +;; + +;;#+windows +(defimplementation doze-in-repl () + (setq *inferior-lisp-sleeping-post* (mt:make-semaphore)) + ;;(loop (sleep 1)) + (mt:semaphore-wait *inferior-lisp-sleeping-post*) + (mk-ext:quit :verbose t) + ) + diff --git a/vim/bundle/slimv/slime/swank/rpc.lisp b/vim/bundle/slimv/slime/swank/rpc.lisp new file mode 100644 index 0000000..e30cc2c --- /dev/null +++ b/vim/bundle/slimv/slime/swank/rpc.lisp @@ -0,0 +1,162 @@ +;;; -*- indent-tabs-mode: nil; coding: latin-1-unix -*- +;;; +;;; swank-rpc.lisp -- Pass remote calls and responses between lisp systems. +;;; +;;; Created 2010, Terje Norderhaug <terje@in-progress.com> +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(in-package swank/rpc) + + +;;;;; Input + +(define-condition swank-reader-error (reader-error) + ((packet :type string :initarg :packet + :reader swank-reader-error.packet) + (cause :type reader-error :initarg :cause + :reader swank-reader-error.cause))) + +(defun read-message (stream package) + (let ((packet (read-packet stream))) + (handler-case (values (read-form packet package)) + (reader-error (c) + (error 'swank-reader-error + :packet packet :cause c))))) + +(defun read-packet (stream) + (let* ((length (parse-header stream)) + (octets (read-chunk stream length))) + (handler-case (swank/backend:utf8-to-string octets) + (error (c) + (error 'swank-reader-error + :packet (asciify octets) + :cause c))))) + +(defun asciify (packet) + (with-output-to-string (*standard-output*) + (loop for code across (etypecase packet + (string (map 'vector #'char-code packet)) + (vector packet)) + do (cond ((<= code #x7f) (write-char (code-char code))) + (t (format t "\\x~x" code)))))) + +(defun parse-header (stream) + (parse-integer (map 'string #'code-char (read-chunk stream 6)) + :radix 16)) + +(defun read-chunk (stream length) + (let* ((buffer (make-array length :element-type '(unsigned-byte 8))) + (count (read-sequence buffer stream))) + (cond ((= count length) + buffer) + ((zerop count) + (error 'end-of-file :stream stream)) + (t + (error "Short read: length=~D count=~D" length count))))) + +(defparameter *validate-input* nil + "Set to true to require input that more strictly conforms to the protocol") + +(defun read-form (string package) + (with-standard-io-syntax + (let ((*package* package)) + (if *validate-input* + (validating-read string) + (read-from-string string))))) + +(defun validating-read (string) + (with-input-from-string (*standard-input* string) + (simple-read))) + +(defun simple-read () + "Read a form that conforms to the protocol, otherwise signal an error." + (let ((c (read-char))) + (case c + (#\( (loop collect (simple-read) + while (ecase (read-char) + (#\) nil) + (#\space t)))) + (#\' `(quote ,(simple-read))) + (t + (cond + ((digit-char-p c) + (parse-integer + (map 'simple-string #'identity + (loop for ch = c then (read-char nil nil) + while (and ch (digit-char-p ch)) + collect ch + finally (unread-char ch))))) + ((or (member c '(#\: #\")) (alpha-char-p c)) + (unread-char c) + (read-preserving-whitespace)) + (t (error "Invalid character ~:c" c))))))) + + +;;;;; Output + +(defun write-message (message package stream) + (let* ((string (prin1-to-string-for-emacs message package)) + (octets (handler-case (swank/backend:string-to-utf8 string) + (error (c) (encoding-error c string)))) + (length (length octets))) + (write-header stream length) + (write-sequence octets stream) + (finish-output stream))) + +;; FIXME: for now just tell emacs that we and an encoding problem. +(defun encoding-error (condition string) + (swank/backend:string-to-utf8 + (prin1-to-string-for-emacs + `(:reader-error + ,(asciify string) + ,(format nil "Error during string-to-utf8: ~a" + (or (ignore-errors (asciify (princ-to-string condition))) + (asciify (princ-to-string (type-of condition)))))) + (find-package :cl)))) + +(defun write-header (stream length) + (declare (type (unsigned-byte 24) length)) + ;;(format *trace-output* "length: ~d (#x~x)~%" length length) + (loop for c across (format nil "~6,'0x" length) + do (write-byte (char-code c) stream))) + +(defun switch-to-double-floats (x) + (typecase x + (double-float x) + (float (coerce x 'double-float)) + (null x) + (list (loop for (x . cdr) on x + collect (switch-to-double-floats x) into result + until (atom cdr) + finally (return (append result (switch-to-double-floats cdr))))) + (t x))) + +(defun prin1-to-string-for-emacs (object package) + (with-standard-io-syntax + (let ((*print-case* :downcase) + (*print-readably* nil) + (*print-pretty* nil) + (*package* package) + ;; Emacs has only double floats. + (*read-default-float-format* 'double-float)) + (prin1-to-string (switch-to-double-floats object))))) + + +#| TEST/DEMO: + +(defparameter *transport* + (with-output-to-string (out) + (write-message '(:message (hello "world")) *package* out) + (write-message '(:return 5) *package* out) + (write-message '(:emacs-rex NIL) *package* out))) + +*transport* + +(with-input-from-string (in *transport*) + (loop while (peek-char T in NIL) + collect (read-message in *package*))) + +|# diff --git a/vim/bundle/slimv/slime/swank/sbcl.lisp b/vim/bundle/slimv/slime/swank/sbcl.lisp new file mode 100644 index 0000000..b54fcd5 --- /dev/null +++ b/vim/bundle/slimv/slime/swank/sbcl.lisp @@ -0,0 +1,2044 @@ +;;;;; -*- indent-tabs-mode: nil -*- +;;; +;;; swank-sbcl.lisp --- SLIME backend for SBCL. +;;; +;;; Created 2003, Daniel Barlow <dan@metacircles.com> +;;; +;;; This code has been placed in the Public Domain. All warranties are +;;; disclaimed. + +;;; Requires the SB-INTROSPECT contrib. + +;;; Administrivia + +(defpackage swank/sbcl + (:use cl swank/backend swank/source-path-parser swank/source-file-cache)) + +(in-package swank/sbcl) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require 'sb-bsd-sockets) + (require 'sb-introspect) + (require 'sb-posix) + (require 'sb-cltl2)) + +(declaim (optimize (debug 2) + (sb-c::insert-step-conditions 0) + (sb-c::insert-debug-catch 0))) + +;;; backwards compability tests + +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; Generate a form suitable for testing for stepper support (0.9.17) + ;; with #+. + (defun sbcl-with-new-stepper-p () + (with-symbol 'enable-stepping 'sb-impl)) + ;; Ditto for weak hash-tables + (defun sbcl-with-weak-hash-tables () + (with-symbol 'hash-table-weakness 'sb-ext)) + ;; And for xref support (1.0.1) + (defun sbcl-with-xref-p () + (with-symbol 'who-calls 'sb-introspect)) + ;; ... for restart-frame support (1.0.2) + (defun sbcl-with-restart-frame () + (with-symbol 'frame-has-debug-tag-p 'sb-debug)) + ;; ... for :setf :inverse info (1.1.17) + (defun sbcl-with-setf-inverse-meta-info () + (boolean-to-feature-expression + ;; going through FIND-SYMBOL since META-INFO was renamed from + ;; TYPE-INFO in 1.2.10. + (let ((sym (find-symbol "META-INFO" "SB-C"))) + (and sym + (fboundp sym) + (funcall sym :setf :inverse ())))))) + +;;; swank-mop + +(import-swank-mop-symbols :sb-mop '(:slot-definition-documentation)) + +(defun swank-mop:slot-definition-documentation (slot) + (sb-pcl::documentation slot t)) + +;; stream support + +(defimplementation gray-package-name () + "SB-GRAY") + +;; Pretty printer calls this, apparently +(defmethod sb-gray:stream-line-length + ((s sb-gray:fundamental-character-input-stream)) + nil) + +;;; Connection info + +(defimplementation lisp-implementation-type-name () + "sbcl") + +;; Declare return type explicitly to shut up STYLE-WARNINGS about +;; %SAP-ALIEN in ENABLE-SIGIO-ON-FD below. +(declaim (ftype (function () (values (signed-byte 32) &optional)) getpid)) +(defimplementation getpid () + (sb-posix:getpid)) + +;;; UTF8 + +(defimplementation string-to-utf8 (string) + (sb-ext:string-to-octets string :external-format :utf8)) + +(defimplementation utf8-to-string (octets) + (sb-ext:octets-to-string octets :external-format :utf8)) + +;;; TCP Server + +(defimplementation preferred-communication-style () + (cond + ;; fixme: when SBCL/win32 gains better select() support, remove + ;; this. + ((member :sb-thread *features*) :spawn) + ((member :win32 *features*) nil) + (t :fd-handler))) + +(defun resolve-hostname (name) + (car (sb-bsd-sockets:host-ent-addresses + (sb-bsd-sockets:get-host-by-name name)))) + +(defimplementation create-socket (host port &key backlog) + (let ((socket (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) + (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port) + (sb-bsd-sockets:socket-listen socket (or backlog 5)) + socket)) + +(defimplementation local-port (socket) + (nth-value 1 (sb-bsd-sockets:socket-name socket))) + +(defimplementation close-socket (socket) + (sb-sys:invalidate-descriptor (socket-fd socket)) + (sb-bsd-sockets:socket-close socket)) + +(defimplementation accept-connection (socket &key + external-format + buffering timeout) + (declare (ignore timeout)) + (make-socket-io-stream (accept socket) external-format + (ecase buffering + ((t :full) :full) + ((nil :none) :none) + ((:line) :line)))) + + +;; The SIGIO stuff should probably be removed as it's unlikey that +;; anybody uses it. +#-win32 +(progn + (defimplementation install-sigint-handler (function) + (sb-sys:enable-interrupt sb-unix:sigint + (lambda (&rest args) + (declare (ignore args)) + (sb-sys:invoke-interruption + (lambda () + (sb-sys:with-interrupts + (funcall function))))))) + + (defvar *sigio-handlers* '() + "List of (key . fn) pairs to be called on SIGIO.") + + (defun sigio-handler (signal code scp) + (declare (ignore signal code scp)) + (sb-sys:with-interrupts + (mapc (lambda (handler) + (funcall (the function (cdr handler)))) + *sigio-handlers*))) + + (defun set-sigio-handler () + (sb-sys:enable-interrupt sb-unix:sigio #'sigio-handler)) + + (defun enable-sigio-on-fd (fd) + (sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async) + (sb-posix::fcntl fd sb-posix::f-setown (getpid)) + (values)) + + (defimplementation add-sigio-handler (socket fn) + (set-sigio-handler) + (let ((fd (socket-fd socket))) + (enable-sigio-on-fd fd) + (push (cons fd fn) *sigio-handlers*))) + + (defimplementation remove-sigio-handlers (socket) + (let ((fd (socket-fd socket))) + (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car)) + (sb-sys:invalidate-descriptor fd)) + (close socket))) + + +(defimplementation add-fd-handler (socket fun) + (let ((fd (socket-fd socket)) + (handler nil)) + (labels ((add () + (setq handler (sb-sys:add-fd-handler fd :input #'run))) + (run (fd) + (sb-sys:remove-fd-handler handler) ; prevent recursion + (unwind-protect + (funcall fun) + (when (sb-unix:unix-fstat fd) ; still open? + (add))))) + (add)))) + +(defimplementation remove-fd-handlers (socket) + (sb-sys:invalidate-descriptor (socket-fd socket))) + +(defimplementation socket-fd (socket) + (etypecase socket + (fixnum socket) + (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket)) + (file-stream (sb-sys:fd-stream-fd socket)))) + +(defimplementation command-line-args () + sb-ext:*posix-argv*) + +(defimplementation dup (fd) + (sb-posix:dup fd)) + +(defvar *wait-for-input-called*) + +(defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (when (boundp '*wait-for-input-called*) + (setq *wait-for-input-called* t)) + (let ((*wait-for-input-called* nil)) + (loop + (let ((ready (remove-if-not #'input-ready-p streams))) + (when ready (return ready))) + (when (check-slime-interrupts) + (return :interrupt)) + (when *wait-for-input-called* + (return :interrupt)) + (when timeout + (return nil)) + (sleep 0.1)))) + +(defun fd-stream-input-buffer-empty-p (stream) + (let ((buffer (sb-impl::fd-stream-ibuf stream))) + (or (not buffer) + (= (sb-impl::buffer-head buffer) + (sb-impl::buffer-tail buffer))))) + +#-win32 +(defun input-ready-p (stream) + (or (not (fd-stream-input-buffer-empty-p stream)) + #+#.(swank/backend:with-symbol 'fd-stream-fd-type 'sb-impl) + (eq :regular (sb-impl::fd-stream-fd-type stream)) + (not (sb-impl::sysread-may-block-p stream)))) + +#+win32 +(progn + (defun input-ready-p (stream) + (or (not (fd-stream-input-buffer-empty-p stream)) + (handle-listen (sockint::fd->handle (sb-impl::fd-stream-fd stream))))) + + (sb-alien:define-alien-routine ("WSACreateEvent" wsa-create-event) + sb-win32:handle) + + (sb-alien:define-alien-routine ("WSACloseEvent" wsa-close-event) + sb-alien:int + (event sb-win32:handle)) + + (defconstant +fd-read+ #.(ash 1 0)) + (defconstant +fd-close+ #.(ash 1 5)) + + (sb-alien:define-alien-routine ("WSAEventSelect" wsa-event-select) + sb-alien:int + (fd sb-alien:int) + (handle sb-win32:handle) + (mask sb-alien:long)) + + (sb-alien:load-shared-object "kernel32.dll") + (sb-alien:define-alien-routine ("WaitForSingleObjectEx" + wait-for-single-object-ex) + sb-alien:int + (event sb-win32:handle) + (milliseconds sb-alien:long) + (alertable sb-alien:int)) + + ;; see SB-WIN32:HANDLE-LISTEN + (defun handle-listen (handle) + (sb-alien:with-alien ((avail sb-win32:dword) + (buf (array char #.sb-win32::input-record-size))) + (unless (zerop (sb-win32:peek-named-pipe handle nil 0 nil + (sb-alien:alien-sap + (sb-alien:addr avail)) + nil)) + (return-from handle-listen (plusp avail))) + + (unless (zerop (sb-win32:peek-console-input handle + (sb-alien:alien-sap buf) + sb-win32::input-record-size + (sb-alien:alien-sap + (sb-alien:addr avail)))) + (return-from handle-listen (plusp avail)))) + + (let ((event (wsa-create-event))) + (wsa-event-select handle event (logior +fd-read+ +fd-close+)) + (let ((val (wait-for-single-object-ex event 0 0))) + (wsa-close-event event) + (unless (= val -1) + (return-from handle-listen (zerop val))))) + + nil) + + ) + +(defvar *external-format-to-coding-system* + '((:iso-8859-1 + "latin-1" "latin-1-unix" "iso-latin-1-unix" + "iso-8859-1" "iso-8859-1-unix") + (:utf-8 "utf-8" "utf-8-unix") + (:euc-jp "euc-jp" "euc-jp-unix") + (:us-ascii "us-ascii" "us-ascii-unix"))) + +;; C.f. R.M.Kreuter in <20536.1219412774@progn.net> on sbcl-general, +;; 2008-08-22. +(defvar *physical-pathname-host* (pathname-host (user-homedir-pathname))) + +(defimplementation filename-to-pathname (filename) + (sb-ext:parse-native-namestring filename *physical-pathname-host*)) + +(defimplementation find-external-format (coding-system) + (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + +(defimplementation set-default-directory (directory) + (let ((directory (truename (merge-pathnames directory)))) + (sb-posix:chdir directory) + (setf *default-pathname-defaults* directory) + (default-directory))) + +(defun make-socket-io-stream (socket external-format buffering) + (let ((args `(,@() + :output t + :input t + :element-type ,(if external-format + 'character + '(unsigned-byte 8)) + :buffering ,buffering + ,@(cond ((and external-format (sb-int:featurep :sb-unicode)) + `(:external-format ,external-format)) + (t '())) + :serve-events ,(eq :fd-handler swank:*communication-style*) + ;; SBCL < 1.0.42.43 doesn't support :SERVE-EVENTS + ;; argument. + :allow-other-keys t))) + (apply #'sb-bsd-sockets:socket-make-stream socket args))) + +(defun accept (socket) + "Like socket-accept, but retry on EAGAIN." + (loop (handler-case + (return (sb-bsd-sockets:socket-accept socket)) + (sb-bsd-sockets:interrupted-error ())))) + + +;;;; Support for SBCL syntax + +;;; SBCL's source code is riddled with #! reader macros. Also symbols +;;; containing `!' have special meaning. We have to work long and +;;; hard to be able to read the source. To deal with #! reader +;;; macros, we use a special readtable. The special symbols are +;;; converted by a condition handler. + +(defun feature-in-list-p (feature list) + (etypecase feature + (symbol (member feature list :test #'eq)) + (cons (flet ((subfeature-in-list-p (subfeature) + (feature-in-list-p subfeature list))) + ;; Don't use ECASE since SBCL also has :host-feature, + ;; don't need to handle it or anything else appearing in + ;; the future or in erronous code. + (case (first feature) + (:or (some #'subfeature-in-list-p (rest feature))) + (:and (every #'subfeature-in-list-p (rest feature))) + (:not (destructuring-bind (e) (cdr feature) + (not (subfeature-in-list-p e))))))))) + +(defun shebang-reader (stream sub-character infix-parameter) + (declare (ignore sub-character)) + (when infix-parameter + (error "illegal read syntax: #~D!" infix-parameter)) + (let ((next-char (read-char stream))) + (unless (find next-char "+-") + (error "illegal read syntax: #!~C" next-char)) + ;; When test is not satisfied + ;; FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then + ;; would become "unless test is satisfied".. + (when (let* ((*package* (find-package "KEYWORD")) + (*read-suppress* nil) + (not-p (char= next-char #\-)) + (feature (read stream))) + (if (feature-in-list-p feature *features*) + not-p + (not not-p))) + ;; Read (and discard) a form from input. + (let ((*read-suppress* t)) + (read stream t nil t)))) + (values)) + +(defvar *shebang-readtable* + (let ((*readtable* (copy-readtable nil))) + (set-dispatch-macro-character #\# #\! + (lambda (s c n) (shebang-reader s c n)) + *readtable*) + *readtable*)) + +(defun shebang-readtable () + *shebang-readtable*) + +(defun sbcl-package-p (package) + (let ((name (package-name package))) + (eql (mismatch "SB-" name) 3))) + +(defun sbcl-source-file-p (filename) + (when filename + (loop for (nil pattern) in (logical-pathname-translations "SYS") + thereis (pathname-match-p filename pattern)))) + +(defun guess-readtable-for-filename (filename) + (if (sbcl-source-file-p filename) + (shebang-readtable) + *readtable*)) + +(defvar *debootstrap-packages* t) + +(defun call-with-debootstrapping (fun) + (handler-bind ((sb-int:bootstrap-package-not-found + #'sb-int:debootstrap-package)) + (funcall fun))) + +(defmacro with-debootstrapping (&body body) + `(call-with-debootstrapping (lambda () ,@body))) + +(defimplementation call-with-syntax-hooks (fn) + (cond ((and *debootstrap-packages* + (sbcl-package-p *package*)) + (with-debootstrapping (funcall fn))) + (t + (funcall fn)))) + +(defimplementation default-readtable-alist () + (let ((readtable (shebang-readtable))) + (loop for p in (remove-if-not #'sbcl-package-p (list-all-packages)) + collect (cons (package-name p) readtable)))) + +;;; Packages + +#+#.(swank/backend:with-symbol 'package-local-nicknames 'sb-ext) +(defimplementation package-local-nicknames (package) + (sb-ext:package-local-nicknames package)) + +;;; Utilities + +#+#.(swank/backend:with-symbol 'function-lambda-list 'sb-introspect) +(defimplementation arglist (fname) + (sb-introspect:function-lambda-list fname)) + +#-#.(swank/backend:with-symbol 'function-lambda-list 'sb-introspect) +(defimplementation arglist (fname) + (sb-introspect:function-arglist fname)) + +(defimplementation function-name (f) + (check-type f function) + (sb-impl::%fun-name f)) + +(defmethod declaration-arglist ((decl-identifier (eql 'optimize))) + (flet ((ensure-list (thing) (if (listp thing) thing (list thing)))) + (let* ((flags (sb-cltl2:declaration-information decl-identifier))) + (if flags + ;; Symbols aren't printed with package qualifiers, but the + ;; FLAGS would have to be fully qualified when used inside a + ;; declaration. So we strip those as long as there's no + ;; better way. (FIXME) + `(&any ,@(remove-if-not + #'(lambda (qualifier) + (find-symbol (symbol-name (first qualifier)) :cl)) + flags :key #'ensure-list)) + (call-next-method))))) + +#+#.(swank/backend:with-symbol 'deftype-lambda-list 'sb-introspect) +(defmethod type-specifier-arglist :around (typespec-operator) + (multiple-value-bind (arglist foundp) + (sb-introspect:deftype-lambda-list typespec-operator) + (if foundp arglist (call-next-method)))) + +(defimplementation type-specifier-p (symbol) + (or (sb-ext:valid-type-specifier-p symbol) + (not (eq (type-specifier-arglist symbol) :not-available)))) + +(defvar *buffer-name* nil) +(defvar *buffer-tmpfile* nil) +(defvar *buffer-offset*) +(defvar *buffer-substring* nil) + +(defvar *previous-compiler-condition* nil + "Used to detect duplicates.") + +(defun handle-notification-condition (condition) + "Handle a condition caused by a compiler warning. +This traps all compiler conditions at a lower-level than using +C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to +craft our own error messages, which can omit a lot of redundant +information." + (unless (or (eq condition *previous-compiler-condition*)) + ;; First resignal warnings, so that outer handlers -- which may choose to + ;; muffle this -- get a chance to run. + (when (typep condition 'warning) + (signal condition)) + (setq *previous-compiler-condition* condition) + (signal-compiler-condition (real-condition condition) + (sb-c::find-error-context nil)))) + +(defun signal-compiler-condition (condition context) + (signal 'compiler-condition + :original-condition condition + :severity (etypecase condition + (sb-ext:compiler-note :note) + (sb-c:compiler-error :error) + (reader-error :read-error) + (error :error) + #+#.(swank/backend:with-symbol redefinition-warning + sb-kernel) + (sb-kernel:redefinition-warning + :redefinition) + (style-warning :style-warning) + (warning :warning)) + :references (condition-references condition) + :message (brief-compiler-message-for-emacs condition) + :source-context (compiler-error-context context) + :location (compiler-note-location condition context))) + +(defun real-condition (condition) + "Return the encapsulated condition or CONDITION itself." + (typecase condition + (sb-int:encapsulated-condition (sb-int:encapsulated-condition condition)) + (t condition))) + +(defun condition-references (condition) + (if (typep condition 'sb-int:reference-condition) + (externalize-reference + (sb-int:reference-condition-references condition)))) + +(defun compiler-note-location (condition context) + (flet ((bailout () + (return-from compiler-note-location + (make-error-location "No error location available")))) + (cond (context + (locate-compiler-note + (sb-c::compiler-error-context-file-name context) + (compiler-source-path context) + (sb-c::compiler-error-context-original-source context))) + ((typep condition 'reader-error) + (let* ((stream (stream-error-stream condition)) + (file (pathname stream))) + (unless (open-stream-p stream) + (bailout)) + (if (compiling-from-buffer-p file) + ;; The stream position for e.g. "comma not inside + ;; backquote" is at the character following the + ;; comma, :offset is 0-based, hence the 1-. + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-offset* + (1- (file-position stream)))) + (progn + (assert (compiling-from-file-p file)) + ;; No 1- because :position is 1-based. + (make-location (list :file (namestring file)) + (list :position (file-position stream))))))) + (t (bailout))))) + +(defun compiling-from-buffer-p (filename) + (and *buffer-name* + ;; The following is to trigger COMPILING-FROM-GENERATED-CODE-P + ;; in LOCATE-COMPILER-NOTE, and allows handling nested + ;; compilation from eg. hitting C-C on (eval-when ... (require ..))). + ;; + ;; PROBE-FILE to handle tempfile directory being a symlink. + (pathnamep filename) + (let ((true1 (probe-file filename)) + (true2 (probe-file *buffer-tmpfile*))) + (and true1 (equal true1 true2))))) + +(defun compiling-from-file-p (filename) + (and (pathnamep filename) + (or (null *buffer-name*) + (null *buffer-tmpfile*) + (let ((true1 (probe-file filename)) + (true2 (probe-file *buffer-tmpfile*))) + (not (and true1 (equal true1 true2))))))) + +(defun compiling-from-generated-code-p (filename source) + (and (eq filename :lisp) (stringp source))) + +(defun locate-compiler-note (file source-path source) + (cond ((compiling-from-buffer-p file) + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-offset* + (source-path-string-position + source-path *buffer-substring*)))) + ((compiling-from-file-p file) + (let ((position (source-path-file-position source-path file))) + (make-location (list :file (namestring file)) + (list :position (and position + (1+ position)))))) + ((compiling-from-generated-code-p file source) + (make-location (list :source-form source) + (list :position 1))) + (t + (error "unhandled case in compiler note ~S ~S ~S" + file source-path source)))) + +(defun brief-compiler-message-for-emacs (condition) + "Briefly describe a compiler error for Emacs. +When Emacs presents the message it already has the source popped up +and the source form highlighted. This makes much of the information in +the error-context redundant." + (let ((sb-int:*print-condition-references* nil)) + (princ-to-string condition))) + +(defun compiler-error-context (error-context) + "Describe a compiler error for Emacs including context information." + (declare (type (or sb-c::compiler-error-context null) error-context)) + (multiple-value-bind (enclosing source) + (if error-context + (values (sb-c::compiler-error-context-enclosing-source error-context) + (sb-c::compiler-error-context-source error-context))) + (and (or enclosing source) + (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]" + enclosing source)))) + +(defun compiler-source-path (context) + "Return the source-path for the current compiler error. +Returns NIL if this cannot be determined by examining internal +compiler state." + (cond ((sb-c::node-p context) + (reverse + (sb-c::source-path-original-source + (sb-c::node-source-path context)))) + ((sb-c::compiler-error-context-p context) + (reverse + (sb-c::compiler-error-context-original-source-path context))))) + +(defimplementation call-with-compilation-hooks (function) + (declare (type function function)) + (handler-bind + ;; N.B. Even though these handlers are called HANDLE-FOO they + ;; actually decline, i.e. the signalling of the original + ;; condition continues upward. + ((sb-c:fatal-compiler-error #'handle-notification-condition) + (sb-c:compiler-error #'handle-notification-condition) + (sb-ext:compiler-note #'handle-notification-condition) + (error #'handle-notification-condition) + (warning #'handle-notification-condition)) + (funcall function))) + +;;; HACK: SBCL 1.2.12 shipped with a bug where +;;; SB-EXT:RESTRICT-COMPILER-POLICY would signal an error when there +;;; were no policy restrictions in place. This workaround ensures the +;;; existence of at least one dummy restriction. +(handler-case (sb-ext:restrict-compiler-policy) + (error () (sb-ext:restrict-compiler-policy 'debug))) + +(defun compiler-policy (qualities) + "Return compiler policy qualities present in the QUALITIES alist. +QUALITIES is an alist with (quality . value)" + #+#.(swank/backend:with-symbol 'restrict-compiler-policy 'sb-ext) + (loop with policy = (sb-ext:restrict-compiler-policy) + for (quality) in qualities + collect (cons quality + (or (cdr (assoc quality policy)) + 0)))) + +(defun (setf compiler-policy) (policy) + (declare (ignorable policy)) + #+#.(swank/backend:with-symbol 'restrict-compiler-policy 'sb-ext) + (loop for (qual . value) in policy + do (sb-ext:restrict-compiler-policy qual value))) + +(defmacro with-compiler-policy (policy &body body) + (let ((current-policy (gensym))) + `(let ((,current-policy (compiler-policy ,policy))) + (setf (compiler-policy) ,policy) + (unwind-protect (progn ,@body) + (setf (compiler-policy) ,current-policy))))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (multiple-value-bind (output-file warnings-p failure-p) + (with-compiler-policy policy + (with-compilation-hooks () + (compile-file input-file :output-file output-file + :external-format external-format))) + (values output-file warnings-p + (or failure-p + (when load-p + ;; Cache the latest source file for definition-finding. + (source-cache-get input-file + (file-write-date input-file)) + (not (load output-file))))))) + +;;;; compile-string + +;;; We copy the string to a temporary file in order to get adequate +;;; semantics for :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL EVAL-WHEN forms +;;; which the previous approach using +;;; (compile nil `(lambda () ,(read-from-string string))) +;;; did not provide. + +(locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) + +(sb-alien:define-alien-routine (#-win32 "tempnam" #+win32 "_tempnam" tempnam) + sb-alien:c-string + (dir sb-alien:c-string) + (prefix sb-alien:c-string)) + +) + +(defun temp-file-name () + "Return a temporary file name to compile strings into." + (tempnam nil nil)) + +(defvar *trap-load-time-warnings* t) + +(defimplementation swank-compile-string (string &key buffer position filename + policy) + (let ((*buffer-name* buffer) + (*buffer-offset* position) + (*buffer-substring* string) + (*buffer-tmpfile* (temp-file-name))) + (labels ((load-it (filename) + (cond (*trap-load-time-warnings* + (with-compilation-hooks () (load filename))) + (t (load filename)))) + (cf () + (with-compiler-policy policy + (with-compilation-unit + (:source-plist (list :emacs-buffer buffer + :emacs-filename filename + :emacs-package (package-name *package*) + :emacs-position position + :emacs-string string) + :source-namestring filename + :allow-other-keys t) + (compile-file *buffer-tmpfile* :external-format :utf-8))))) + (with-open-file (s *buffer-tmpfile* :direction :output :if-exists :error + :external-format :utf-8) + (write-string string s)) + (unwind-protect + (multiple-value-bind (output-file warningsp failurep) + (with-compilation-hooks () (cf)) + (declare (ignore warningsp)) + (when output-file + (load-it output-file)) + (not failurep)) + (ignore-errors + (delete-file *buffer-tmpfile*) + (delete-file (compile-file-pathname *buffer-tmpfile*))))))) + +;;;; Definitions + +(defparameter *definition-types* + '(:variable defvar + :constant defconstant + :type deftype + :symbol-macro define-symbol-macro + :macro defmacro + :compiler-macro define-compiler-macro + :function defun + :generic-function defgeneric + :method defmethod + :setf-expander define-setf-expander + :structure defstruct + :condition define-condition + :class defclass + :method-combination define-method-combination + :package defpackage + :transform :deftransform + :optimizer :defoptimizer + :vop :define-vop + :source-transform :define-source-transform + :ir1-convert :def-ir1-translator + :declaration declaim + :alien-type :define-alien-type) + "Map SB-INTROSPECT definition type names to Slime-friendly forms") + +(defun definition-specifier (type) + "Return a pretty specifier for NAME representing a definition of type TYPE." + (getf *definition-types* type)) + +(defun make-dspec (type name source-location) + (list* (definition-specifier type) + name + (sb-introspect::definition-source-description source-location))) + +(defimplementation find-definitions (name) + (loop for type in *definition-types* by #'cddr + for defsrcs = (sb-introspect:find-definition-sources-by-name name type) + append (loop for defsrc in defsrcs collect + (list (make-dspec type name defsrc) + (converting-errors-to-error-location + (definition-source-for-emacs defsrc + type name)))))) + +(defimplementation find-source-location (obj) + (flet ((general-type-of (obj) + (typecase obj + (method :method) + (generic-function :generic-function) + (function :function) + (structure-class :structure-class) + (class :class) + (method-combination :method-combination) + (package :package) + (condition :condition) + (structure-object :structure-object) + (standard-object :standard-object) + (t :thing))) + (to-string (obj) + (typecase obj + ;; Packages are possibly named entities. + (package (princ-to-string obj)) + ((or structure-object standard-object condition) + (with-output-to-string (s) + (print-unreadable-object (obj s :type t :identity t)))) + (t (princ-to-string obj))))) + (converting-errors-to-error-location + (let ((defsrc (sb-introspect:find-definition-source obj))) + (definition-source-for-emacs defsrc + (general-type-of obj) + (to-string obj)))))) + +(defmacro with-definition-source ((&rest names) obj &body body) + "Like with-slots but works only for structs." + (flet ((reader (slot) + ;; Use read-from-string instead of intern so that + ;; conc-name can be a string such as ext:struct- and not + ;; cause errors and not force interning ext::struct- + (read-from-string + (concatenate 'string "sb-introspect:definition-source-" + (string slot))))) + (let ((tmp (gensym "OO-"))) + ` (let ((,tmp ,obj)) + (symbol-macrolet + ,(loop for name in names collect + (typecase name + (symbol `(,name (,(reader name) ,tmp))) + (cons `(,(first name) (,(reader (second name)) ,tmp))) + (t (error "Malformed syntax in WITH-STRUCT: ~A" name)))) + ,@body))))) + +(defun categorize-definition-source (definition-source) + (with-definition-source (pathname form-path character-offset plist) + definition-source + (let ((file-p (and pathname (probe-file pathname) + (or form-path character-offset)))) + (cond ((and (getf plist :emacs-buffer) file-p) :buffer-and-file) + ((getf plist :emacs-buffer) :buffer) + (file-p :file) + (pathname :file-without-position) + (t :invalid))))) + +#+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect) +(defun form-number-position (definition-source stream) + (let* ((tlf-number (car (sb-introspect:definition-source-form-path definition-source))) + (form-number (sb-introspect:definition-source-form-number definition-source))) + (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream) + (let* ((path-table (sb-di::form-number-translations tlf 0)) + (path (cond ((<= (length path-table) form-number) + (warn "inconsistent form-number-translations") + (list 0)) + (t + (reverse (cdr (aref path-table form-number))))))) + (source-path-source-position path tlf pos-map))))) + +#+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect) +(defun file-form-number-position (definition-source) + (let* ((code-date (sb-introspect:definition-source-file-write-date definition-source)) + (filename (sb-introspect:definition-source-pathname definition-source)) + (*readtable* (guess-readtable-for-filename filename)) + (source-code (get-source-code filename code-date))) + (with-debootstrapping + (with-input-from-string (s source-code) + (form-number-position definition-source s))))) + +#+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect) +(defun string-form-number-position (definition-source string) + (with-input-from-string (s string) + (form-number-position definition-source s))) + +(defun definition-source-buffer-location (definition-source) + (with-definition-source (form-path character-offset plist) definition-source + (destructuring-bind (&key emacs-buffer emacs-position emacs-directory + emacs-string &allow-other-keys) + plist + (let ((*readtable* (guess-readtable-for-filename emacs-directory)) + start + end) + (with-debootstrapping + (or + (and form-path + (or + #+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect) + (setf (values start end) + (and (sb-introspect:definition-source-form-number definition-source) + (string-form-number-position definition-source emacs-string))) + (setf (values start end) + (source-path-string-position form-path emacs-string)))) + (setf start character-offset + end most-positive-fixnum))) + (make-location + `(:buffer ,emacs-buffer) + `(:offset ,emacs-position ,start) + `(:snippet + ,(subseq emacs-string + start + (min end (+ start *source-snippet-size*))))))))) + +(defun definition-source-file-location (definition-source) + (with-definition-source (pathname form-path character-offset plist + file-write-date) definition-source + (let* ((namestring (namestring (translate-logical-pathname pathname))) + (pos (or (and form-path + (or + #+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect) + (and (sb-introspect:definition-source-form-number definition-source) + (ignore-errors (file-form-number-position definition-source))) + (ignore-errors + (source-file-position namestring file-write-date + form-path)))) + character-offset)) + (snippet (source-hint-snippet namestring file-write-date pos))) + (make-location `(:file ,namestring) + ;; /file positions/ in Common Lisp start from + ;; 0, buffer positions in Emacs start from 1. + `(:position ,(1+ pos)) + `(:snippet ,snippet))))) + +(defun definition-source-buffer-and-file-location (definition-source) + (let ((buffer (definition-source-buffer-location definition-source))) + (make-location (list :buffer-and-file + (cadr (location-buffer buffer)) + (namestring (sb-introspect:definition-source-pathname + definition-source))) + (location-position buffer) + (location-hints buffer)))) + +(defun definition-source-for-emacs (definition-source type name) + (with-definition-source (pathname form-path character-offset plist + file-write-date) + definition-source + (ecase (categorize-definition-source definition-source) + (:buffer-and-file + (definition-source-buffer-and-file-location definition-source)) + (:buffer + (definition-source-buffer-location definition-source)) + (:file + (definition-source-file-location definition-source)) + (:file-without-position + (make-location `(:file ,(namestring + (translate-logical-pathname pathname))) + '(:position 1) + (when (eql type :function) + `(:snippet ,(format nil "(defun ~a " + (symbol-name name)))))) + (:invalid + (error "DEFINITION-SOURCE of ~(~A~) ~A did not contain ~ + meaningful information." + type name))))) + +(defun source-file-position (filename write-date form-path) + (let ((source (get-source-code filename write-date)) + (*readtable* (guess-readtable-for-filename filename))) + (with-debootstrapping + (source-path-string-position form-path source)))) + +(defun source-hint-snippet (filename write-date position) + (read-snippet-from-string (get-source-code filename write-date) position)) + +(defun function-source-location (function &optional name) + (declare (type function function)) + (definition-source-for-emacs (sb-introspect:find-definition-source function) + :function + (or name (function-name function)))) + +(defun setf-expander (symbol) + (or + #+#.(swank/sbcl::sbcl-with-setf-inverse-meta-info) + (sb-int:info :setf :inverse symbol) + (sb-int:info :setf :expander symbol))) + +(defimplementation describe-symbol-for-emacs (symbol) + "Return a plist describing SYMBOL. +Return NIL if the symbol is unbound." + (let ((result '())) + (flet ((doc (kind) + (or (documentation symbol kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (multiple-value-bind (kind recorded-p) + (sb-int:info :variable :kind symbol) + (declare (ignore kind)) + (if (or (boundp symbol) recorded-p) + (doc 'variable)))) + (when (fboundp symbol) + (maybe-push + (cond ((macro-function symbol) :macro) + ((special-operator-p symbol) :special-operator) + ((typep (fdefinition symbol) 'generic-function) + :generic-function) + (t :function)) + (doc 'function))) + (maybe-push + :setf (and (setf-expander symbol) + (doc 'setf))) + (maybe-push + :type (if (sb-int:info :type :kind symbol) + (doc 'type))) + result))) + +(defimplementation describe-definition (symbol type) + (case type + (:variable + (describe symbol)) + (:function + (describe (symbol-function symbol))) + (:setf + (describe (setf-expander symbol))) + (:class + (describe (find-class symbol))) + (:type + (describe (sb-kernel:values-specifier-type symbol))))) + +#+#.(swank/sbcl::sbcl-with-xref-p) +(progn + (defmacro defxref (name &optional fn-name) + `(defimplementation ,name (what) + (sanitize-xrefs + (mapcar #'source-location-for-xref-data + (,(find-symbol (symbol-name (if fn-name + fn-name + name)) + "SB-INTROSPECT") + what))))) + (defxref who-calls) + (defxref who-binds) + (defxref who-sets) + (defxref who-references) + (defxref who-macroexpands) + #+#.(swank/backend:with-symbol 'who-specializes-directly 'sb-introspect) + (defxref who-specializes who-specializes-directly)) + +(defun source-location-for-xref-data (xref-data) + (destructuring-bind (name . defsrc) xref-data + (list name (converting-errors-to-error-location + (definition-source-for-emacs defsrc 'function name))))) + +(defimplementation list-callers (symbol) + (let ((fn (fdefinition symbol))) + (sanitize-xrefs + (mapcar #'function-dspec (sb-introspect:find-function-callers fn))))) + +(defimplementation list-callees (symbol) + (let ((fn (fdefinition symbol))) + (sanitize-xrefs + (mapcar #'function-dspec (sb-introspect:find-function-callees fn))))) + +(defun sanitize-xrefs (xrefs) + (remove-duplicates + (remove-if (lambda (f) + (member f (ignored-xref-function-names))) + (loop for entry in xrefs + for name = (car entry) + collect (if (and (consp name) + (member (car name) + '(sb-pcl::fast-method + sb-pcl::slow-method + sb-pcl::method))) + (cons (cons 'defmethod (cdr name)) + (cdr entry)) + entry)) + :key #'car) + :test (lambda (a b) + (and (eq (first a) (first b)) + (equal (second a) (second b)))))) + +(defun ignored-xref-function-names () + #-#.(swank/sbcl::sbcl-with-new-stepper-p) + '(nil sb-c::step-form sb-c::step-values) + #+#.(swank/sbcl::sbcl-with-new-stepper-p) + '(nil)) + +(defun function-dspec (fn) + "Describe where the function FN was defined. +Return a list of the form (NAME LOCATION)." + (let ((name (function-name fn))) + (list name (converting-errors-to-error-location + (function-source-location fn name))))) + +;;; macroexpansion + +(defimplementation macroexpand-all (form &optional env) + (sb-cltl2:macroexpand-all form env)) + +(defimplementation collect-macro-forms (form &optional environment) + (let ((macro-forms '()) + (compiler-macro-forms '()) + (function-quoted-forms '())) + (sb-walker:walk-form + form environment + (lambda (form context environment) + (declare (ignore context)) + (when (and (consp form) + (symbolp (car form))) + (cond ((eq (car form) 'function) + (push (cadr form) function-quoted-forms)) + ((member form function-quoted-forms) + nil) + ((macro-function (car form) environment) + (push form macro-forms)) + ((not (eq form (compiler-macroexpand-1 form environment))) + (push form compiler-macro-forms)))) + form)) + (values macro-forms compiler-macro-forms))) + + +;;; Debugging + +;;; Notice that SB-EXT:*INVOKE-DEBUGGER-HOOK* is slightly stronger +;;; than just a hook into BREAK. In particular, it'll make +;;; (LET ((*DEBUGGER-HOOK* NIL)) ..error..) drop into SLDB rather +;;; than the native debugger. That should probably be considered a +;;; feature. + +(defun make-invoke-debugger-hook (hook) + (when hook + #'(sb-int:named-lambda swank-invoke-debugger-hook + (condition old-hook) + (if *debugger-hook* + nil ; decline, *DEBUGGER-HOOK* will be tried next. + (funcall hook condition old-hook))))) + +(defun set-break-hook (hook) + (setq sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))) + +(defun call-with-break-hook (hook continuation) + (let ((sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))) + (funcall continuation))) + +(defimplementation install-debugger-globally (function) + (setq *debugger-hook* function) + (set-break-hook function)) + +(defimplementation condition-extras (condition) + (cond #+#.(swank/sbcl::sbcl-with-new-stepper-p) + ((typep condition 'sb-impl::step-form-condition) + `((:show-frame-source 0))) + ((typep condition 'sb-int:reference-condition) + (let ((refs (sb-int:reference-condition-references condition))) + (if refs + `((:references ,(externalize-reference refs)))))))) + +(defun externalize-reference (ref) + (etypecase ref + (null nil) + (cons (cons (externalize-reference (car ref)) + (externalize-reference (cdr ref)))) + ((or string number) ref) + (symbol + (cond ((eq (symbol-package ref) (symbol-package :test)) + ref) + (t (symbol-name ref)))))) + +(defvar *sldb-stack-top*) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (declare (type function debugger-loop-fn)) + (let ((*sldb-stack-top* + (if (and (not *debug-swank-backend*) + sb-debug:*stack-top-hint*) + #+#.(swank/backend:with-symbol 'resolve-stack-top-hint 'sb-debug) + (sb-debug::resolve-stack-top-hint) + #-#.(swank/backend:with-symbol 'resolve-stack-top-hint 'sb-debug) + sb-debug:*stack-top-hint* + (sb-di:top-frame))) + (sb-debug:*stack-top-hint* nil)) + (handler-bind ((sb-di:debug-condition + (lambda (condition) + (signal 'sldb-condition + :original-condition condition)))) + (funcall debugger-loop-fn)))) + +#+#.(swank/sbcl::sbcl-with-new-stepper-p) +(progn + (defimplementation activate-stepping (frame) + (declare (ignore frame)) + (sb-impl::enable-stepping)) + (defimplementation sldb-stepper-condition-p (condition) + (typep condition 'sb-ext:step-form-condition)) + (defimplementation sldb-step-into () + (invoke-restart 'sb-ext:step-into)) + (defimplementation sldb-step-next () + (invoke-restart 'sb-ext:step-next)) + (defimplementation sldb-step-out () + (invoke-restart 'sb-ext:step-out))) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook) + #+#.(swank/sbcl::sbcl-with-new-stepper-p) + (sb-ext:*stepper-hook* + (lambda (condition) + (typecase condition + (sb-ext:step-form-condition + (let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame))) + (sb-impl::invoke-debugger condition))))))) + (handler-bind (#+#.(swank/sbcl::sbcl-with-new-stepper-p) + (sb-ext:step-condition #'sb-impl::invoke-stepper)) + (call-with-break-hook hook fun)))) + +(defun nth-frame (index) + (do ((frame *sldb-stack-top* (sb-di:frame-down frame)) + (i index (1- i))) + ((zerop i) frame))) + +(defimplementation compute-backtrace (start end) + "Return a list of frames starting with frame number START and +continuing to frame number END or, if END is nil, the last frame on the +stack." + (let ((end (or end most-positive-fixnum))) + (loop for f = (nth-frame start) then (sb-di:frame-down f) + for i from start below end + while f collect f))) + +(defimplementation print-frame (frame stream) + (sb-debug::print-frame-call frame stream)) + +(defimplementation frame-restartable-p (frame) + #+#.(swank/sbcl::sbcl-with-restart-frame) + (not (null (sb-debug:frame-has-debug-tag-p frame)))) + +(defimplementation frame-call (frame-number) + (multiple-value-bind (name args) + (sb-debug::frame-call (nth-frame frame-number)) + (with-output-to-string (stream) + (locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) + (pprint-logical-block (stream nil :prefix "(" :suffix ")") + (locally (declare (sb-ext:unmuffle-conditions sb-ext:compiler-note)) + (let ((*print-length* nil) + (*print-level* nil)) + (prin1 (sb-debug::ensure-printable-object name) stream)) + (let ((args (sb-debug::ensure-printable-object args))) + (if (listp args) + (format stream "~{ ~_~S~}" args) + (format stream " ~S" args))))))))) + +;;;; Code-location -> source-location translation + +;;; If debug-block info is avaibale, we determine the file position of +;;; the source-path for a code-location. If the code was compiled +;;; with C-c C-c, we have to search the position in the source string. +;;; If there's no debug-block info, we return the (less precise) +;;; source-location of the corresponding function. + +(defun code-location-source-location (code-location) + (let* ((dsource (sb-di:code-location-debug-source code-location)) + (plist (sb-c::debug-source-plist dsource)) + (package (getf plist :emacs-package)) + (*package* (or (and package + (find-package package)) + *package*))) + (if (getf plist :emacs-buffer) + (emacs-buffer-source-location code-location plist) + #+#.(swank/backend:with-symbol 'debug-source-from 'sb-di) + (ecase (sb-di:debug-source-from dsource) + (:file (file-source-location code-location)) + (:lisp (lisp-source-location code-location))) + #-#.(swank/backend:with-symbol 'debug-source-from 'sb-di) + (if (sb-di:debug-source-namestring dsource) + (file-source-location code-location) + (lisp-source-location code-location))))) + +;;; FIXME: The naming policy of source-location functions is a bit +;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the +;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co +;;; which returns the source location for a _code-location_. +;;; +;;; Maybe these should be named code-location-file-source-location, +;;; etc, turned into generic functions, or something. In the very +;;; least the names should indicate the main entry point vs. helper +;;; status. + +(defun file-source-location (code-location) + (if (code-location-has-debug-block-info-p code-location) + (source-file-source-location code-location) + (fallback-source-location code-location))) + +(defun fallback-source-location (code-location) + (let ((fun (code-location-debug-fun-fun code-location))) + (cond (fun (function-source-location fun)) + (t (error "Cannot find source location for: ~A " code-location))))) + +(defun lisp-source-location (code-location) + (let ((source (prin1-to-string + (sb-debug::code-location-source-form code-location 100))) + (condition swank:*swank-debugger-condition*)) + (if (and (typep condition 'sb-impl::step-form-condition) + (search "SB-IMPL::WITH-STEPPING-ENABLED" source + :test #'char-equal) + (search "SB-IMPL::STEP-FINISHED" source :test #'char-equal)) + ;; The initial form is utterly uninteresting -- and almost + ;; certainly right there in the REPL. + (make-error-location "Stepping...") + (make-location `(:source-form ,source) '(:position 1))))) + +(defun emacs-buffer-source-location (code-location plist) + (if (code-location-has-debug-block-info-p code-location) + (destructuring-bind (&key emacs-buffer emacs-position emacs-string + &allow-other-keys) + plist + (let* ((pos (string-source-position code-location emacs-string)) + (snipped (read-snippet-from-string emacs-string pos))) + (make-location `(:buffer ,emacs-buffer) + `(:offset ,emacs-position ,pos) + `(:snippet ,snipped)))) + (fallback-source-location code-location))) + +(defun source-file-source-location (code-location) + (let* ((code-date (code-location-debug-source-created code-location)) + (filename (code-location-debug-source-name code-location)) + (*readtable* (guess-readtable-for-filename filename)) + (source-code (get-source-code filename code-date))) + (with-debootstrapping + (with-input-from-string (s source-code) + (let* ((pos (stream-source-position code-location s)) + (snippet (read-snippet s pos))) + (make-location `(:file ,filename) + `(:position ,pos) + `(:snippet ,snippet))))))) + +(defun code-location-debug-source-name (code-location) + (namestring (truename (#.(swank/backend:choose-symbol + 'sb-c 'debug-source-name + 'sb-c 'debug-source-namestring) + (sb-di::code-location-debug-source code-location))))) + +(defun code-location-debug-source-created (code-location) + (sb-c::debug-source-created + (sb-di::code-location-debug-source code-location))) + +(defun code-location-debug-fun-fun (code-location) + (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location))) + +(defun code-location-has-debug-block-info-p (code-location) + (handler-case + (progn (sb-di:code-location-debug-block code-location) + t) + (sb-di:no-debug-blocks () nil))) + +(defun stream-source-position (code-location stream) + (let* ((cloc (sb-debug::maybe-block-start-location code-location)) + (tlf-number (sb-di::code-location-toplevel-form-offset cloc)) + (form-number (sb-di::code-location-form-number cloc))) + (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream) + (let* ((path-table (sb-di::form-number-translations tlf 0)) + (path (cond ((<= (length path-table) form-number) + (warn "inconsistent form-number-translations") + (list 0)) + (t + (reverse (cdr (aref path-table form-number))))))) + (source-path-source-position path tlf pos-map))))) + +(defun string-source-position (code-location string) + (with-input-from-string (s string) + (stream-source-position code-location s))) + +;;; source-path-file-position and friends are in source-path-parser + +(defimplementation frame-source-location (index) + (converting-errors-to-error-location + (code-location-source-location + (sb-di:frame-code-location (nth-frame index))))) + +(defvar *keep-non-valid-locals* nil) + +(defun frame-debug-vars (frame) + "Return a vector of debug-variables in frame." + (let ((all-vars (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame)))) + (cond (*keep-non-valid-locals* all-vars) + (t (let ((loc (sb-di:frame-code-location frame))) + (remove-if (lambda (var) + (ecase (sb-di:debug-var-validity var loc) + (:valid nil) + ((:invalid :unknown) t))) + all-vars)))))) + +(defun debug-var-value (var frame location) + (ecase (sb-di:debug-var-validity var location) + (:valid (sb-di:debug-var-value var frame)) + ((:invalid :unknown) ':<not-available>))) + +(defun debug-var-info (var) + ;; Introduced by SBCL 1.0.49.76. + (let ((s (find-symbol "DEBUG-VAR-INFO" :sb-di))) + (when (and s (fboundp s)) + (funcall s var)))) + +(defimplementation frame-locals (index) + (let* ((frame (nth-frame index)) + (loc (sb-di:frame-code-location frame)) + (vars (frame-debug-vars frame)) + ;; Since SBCL 1.0.49.76 PREPROCESS-FOR-EVAL understands SB-DEBUG::MORE + ;; specially. + (more-name (or (find-symbol "MORE" :sb-debug) 'more)) + (more-context nil) + (more-count nil) + (more-id 0)) + (when vars + (let ((locals + (loop for v across vars + do (when (eq (sb-di:debug-var-symbol v) more-name) + (incf more-id)) + (case (debug-var-info v) + (:more-context + (setf more-context (debug-var-value v frame loc))) + (:more-count + (setf more-count (debug-var-value v frame loc)))) + collect + (list :name (sb-di:debug-var-symbol v) + :id (sb-di:debug-var-id v) + :value (debug-var-value v frame loc))))) + (when (and more-context more-count) + (setf locals (append locals + (list + (list :name more-name + :id more-id + :value (multiple-value-list + (sb-c:%more-arg-values + more-context + 0 more-count))))))) + locals)))) + +(defimplementation frame-var-value (frame var) + (let* ((frame (nth-frame frame)) + (vars (frame-debug-vars frame)) + (loc (sb-di:frame-code-location frame)) + (dvar (if (= var (length vars)) + ;; If VAR is out of bounds, it must be the fake var + ;; we made up for &MORE. + (let* ((context-var (find :more-context vars + :key #'debug-var-info)) + (more-context (debug-var-value context-var frame + loc)) + (count-var (find :more-count vars + :key #'debug-var-info)) + (more-count (debug-var-value count-var frame loc))) + (return-from frame-var-value + (multiple-value-list (sb-c:%more-arg-values + more-context + 0 more-count)))) + (aref vars var)))) + (debug-var-value dvar frame loc))) + +(defimplementation frame-catch-tags (index) + (mapcar #'car (sb-di:frame-catches (nth-frame index)))) + +(defimplementation eval-in-frame (form index) + (let ((frame (nth-frame index))) + (funcall (the function + (sb-di:preprocess-for-eval form + (sb-di:frame-code-location frame))) + frame))) + +(defimplementation frame-package (frame-number) + (let* ((frame (nth-frame frame-number)) + (fun (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame)))) + (when fun + (let ((name (function-name fun))) + (typecase name + (null nil) + (symbol (symbol-package name)) + ((cons (eql setf) (cons symbol)) (symbol-package (cadr name)))))))) + +#+#.(swank/sbcl::sbcl-with-restart-frame) +(progn + (defimplementation return-from-frame (index form) + (let* ((frame (nth-frame index))) + (cond ((sb-debug:frame-has-debug-tag-p frame) + (let ((values (multiple-value-list (eval-in-frame form index)))) + (sb-debug:unwind-to-frame-and-call frame + (lambda () + (values-list values))))) + (t (format nil "Cannot return from frame: ~S" frame))))) + + (defimplementation restart-frame (index) + (let ((frame (nth-frame index))) + (when (sb-debug:frame-has-debug-tag-p frame) + (multiple-value-bind (fname args) (sb-debug::frame-call frame) + (multiple-value-bind (fun arglist) + (if (and (sb-int:legal-fun-name-p fname) (fboundp fname)) + (values (fdefinition fname) args) + (values (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame)) + (sb-debug::frame-args-as-list frame))) + (when (functionp fun) + (sb-debug:unwind-to-frame-and-call + frame + (lambda () + ;; Ensure TCO. + (declare (optimize (debug 0))) + (apply fun arglist))))))) + (format nil "Cannot restart frame: ~S" frame)))) + +;; FIXME: this implementation doesn't unwind the stack before +;; re-invoking the function, but it's better than no implementation at +;; all. +#-#.(swank/sbcl::sbcl-with-restart-frame) +(progn + (defun sb-debug-catch-tag-p (tag) + (and (symbolp tag) + (not (symbol-package tag)) + (string= tag :sb-debug-catch-tag))) + + (defimplementation return-from-frame (index form) + (let* ((frame (nth-frame index)) + (probe (assoc-if #'sb-debug-catch-tag-p + (sb-di::frame-catches frame)))) + (cond (probe (throw (car probe) (eval-in-frame form index))) + (t (format nil "Cannot return from frame: ~S" frame))))) + + (defimplementation restart-frame (index) + (let ((frame (nth-frame index))) + (return-from-frame index (sb-debug::frame-call-as-list frame))))) + +;;;;; reference-conditions + +(defimplementation print-condition (condition stream) + (let ((sb-int:*print-condition-references* nil)) + (princ condition stream))) + + +;;;; Profiling + +(defimplementation profile (fname) + (when fname (eval `(sb-profile:profile ,fname)))) + +(defimplementation unprofile (fname) + (when fname (eval `(sb-profile:unprofile ,fname)))) + +(defimplementation unprofile-all () + (sb-profile:unprofile) + "All functions unprofiled.") + +(defimplementation profile-report () + (sb-profile:report)) + +(defimplementation profile-reset () + (sb-profile:reset) + "Reset profiling counters.") + +(defimplementation profiled-functions () + (sb-profile:profile)) + +(defimplementation profile-package (package callers methods) + (declare (ignore callers methods)) + (eval `(sb-profile:profile ,(package-name (find-package package))))) + + +;;;; Inspector + +(defmethod emacs-inspect ((o t)) + (cond ((sb-di::indirect-value-cell-p o) + (label-value-line* (:value (sb-kernel:value-cell-ref o)))) + (t + (multiple-value-bind (text label parts) (sb-impl::inspected-parts o) + (list* (string-right-trim '(#\Newline) text) + '(:newline) + (if label + (loop for (l . v) in parts + append (label-value-line l v)) + (loop for value in parts + for i from 0 + append (label-value-line i value)))))))) + +(defmethod emacs-inspect ((o function)) + (let ((header (sb-kernel:widetag-of o))) + (cond ((= header sb-vm:simple-fun-header-widetag) + (label-value-line* + (:name (sb-kernel:%simple-fun-name o)) + (:arglist (sb-kernel:%simple-fun-arglist o)) + (:self (sb-kernel:%simple-fun-self o)) + (:next (sb-kernel:%simple-fun-next o)) + (:type (sb-kernel:%simple-fun-type o)) + (:code (sb-kernel:fun-code-header o)))) + ((= header sb-vm:closure-header-widetag) + (append + (label-value-line :function (sb-kernel:%closure-fun o)) + `("Closed over values:" (:newline)) + (loop for i below (1- (sb-kernel:get-closure-length o)) + append (label-value-line + i (sb-kernel:%closure-index-ref o i))))) + (t (call-next-method o))))) + +(defmethod emacs-inspect ((o sb-kernel:code-component)) + (append + (label-value-line* + (:code-size (sb-kernel:%code-code-size o)) + (:entry-points (sb-kernel:%code-entry-points o)) + (:debug-info (sb-kernel:%code-debug-info o))) + `("Constants:" (:newline)) + (loop for i from sb-vm:code-constants-offset + below + (#.(swank/backend:choose-symbol 'sb-kernel 'code-header-words + 'sb-kernel 'get-header-data) + o) + append (label-value-line i (sb-kernel:code-header-ref o i))) + `("Code:" (:newline) + , (with-output-to-string (s) + (cond ((sb-kernel:%code-debug-info o) + (sb-disassem:disassemble-code-component o :stream s)) + (t + (sb-disassem:disassemble-memory + (sb-disassem::align + (+ (logandc2 (sb-kernel:get-lisp-obj-address o) + sb-vm:lowtag-mask) + (* sb-vm:code-constants-offset + sb-vm:n-word-bytes)) + (ash 1 sb-vm:n-lowtag-bits)) + (ash (sb-kernel:%code-code-size o) sb-vm:word-shift) + :stream s))))))) + +(defmethod emacs-inspect ((o sb-ext:weak-pointer)) + (label-value-line* + (:value (sb-ext:weak-pointer-value o)))) + +(defmethod emacs-inspect ((o sb-kernel:fdefn)) + (label-value-line* + (:name (sb-kernel:fdefn-name o)) + (:function (sb-kernel:fdefn-fun o)))) + +(defmethod emacs-inspect :around ((o generic-function)) + (append + (call-next-method) + (label-value-line* + (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o)) + (:initial-methods (sb-pcl::generic-function-initial-methods o)) + ))) + + +;;;; Multiprocessing + +#+(and sb-thread + #.(swank/backend:with-symbol "THREAD-NAME" "SB-THREAD")) +(progn + (defvar *thread-id-counter* 0) + + (defvar *thread-id-counter-lock* + (sb-thread:make-mutex :name "thread id counter lock")) + + (defun next-thread-id () + (sb-thread:with-mutex (*thread-id-counter-lock*) + (incf *thread-id-counter*))) + + (defparameter *thread-id-map* (make-hash-table)) + + ;; This should be a thread -> id map but as weak keys are not + ;; supported it is id -> map instead. + (defvar *thread-id-map-lock* + (sb-thread:make-mutex :name "thread id map lock")) + + (defimplementation spawn (fn &key name) + (sb-thread:make-thread fn :name name)) + + (defimplementation thread-id (thread) + (block thread-id + (sb-thread:with-mutex (*thread-id-map-lock*) + (loop for id being the hash-key in *thread-id-map* + using (hash-value thread-pointer) + do + (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer))) + (cond ((null maybe-thread) + ;; the value is gc'd, remove it manually + (remhash id *thread-id-map*)) + ((eq thread maybe-thread) + (return-from thread-id id))))) + ;; lazy numbering + (let ((id (next-thread-id))) + (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread)) + id)))) + + (defimplementation find-thread (id) + (sb-thread:with-mutex (*thread-id-map-lock*) + (let ((thread-pointer (gethash id *thread-id-map*))) + (if thread-pointer + (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer))) + (if maybe-thread + maybe-thread + ;; the value is gc'd, remove it manually + (progn + (remhash id *thread-id-map*) + nil))) + nil)))) + + (defimplementation thread-name (thread) + ;; sometimes the name is not a string (e.g. NIL) + (princ-to-string (sb-thread:thread-name thread))) + + (defimplementation thread-status (thread) + (if (sb-thread:thread-alive-p thread) + "Running" + "Stopped")) + + (defimplementation make-lock (&key name) + (sb-thread:make-mutex :name name)) + + (defimplementation call-with-lock-held (lock function) + (declare (type function function)) + (sb-thread:with-recursive-lock (lock) (funcall function))) + + (defimplementation current-thread () + sb-thread:*current-thread*) + + (defimplementation all-threads () + (sb-thread:list-all-threads)) + + (defimplementation interrupt-thread (thread fn) + (sb-thread:interrupt-thread thread fn)) + + (defimplementation kill-thread (thread) + (sb-thread:terminate-thread thread)) + + (defimplementation thread-alive-p (thread) + (sb-thread:thread-alive-p thread)) + + (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock")) + (defvar *mailboxes* (list)) + (declaim (type list *mailboxes*)) + + (defstruct (mailbox (:conc-name mailbox.)) + thread + (mutex (sb-thread:make-mutex)) + (waitqueue (sb-thread:make-waitqueue)) + (queue '() :type list)) + + (defun mailbox (thread) + "Return THREAD's mailbox." + (sb-thread:with-mutex (*mailbox-lock*) + (or (find thread *mailboxes* :key #'mailbox.thread) + (let ((mb (make-mailbox :thread thread))) + (push mb *mailboxes*) + mb)))) + + (defimplementation send (thread message) + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) + (sb-thread:with-mutex (mutex) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + (sb-thread:condition-broadcast (mailbox.waitqueue mbox))))) + + + (defun condition-timed-wait (waitqueue mutex timeout) + (macrolet ((foo () + (cond ((member :sb-lutex *features*) ; Darwin + '(sb-thread:condition-wait waitqueue mutex)) + (t + '(handler-case + (let ((*break-on-signals* nil)) + (sb-sys:with-deadline (:seconds timeout + :override t) + (sb-thread:condition-wait waitqueue mutex) t)) + (sb-ext:timeout () + nil)))))) + (foo))) + + (defimplementation receive-if (test &optional timeout) + (let* ((mbox (mailbox (current-thread))) + (mutex (mailbox.mutex mbox)) + (waitq (mailbox.waitqueue mbox))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (sb-thread:with-mutex (mutex) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail)))) + (when (eq timeout t) (return (values nil t))) + (condition-timed-wait waitq mutex 0.2))))) + + (let ((alist '()) + (mutex (sb-thread:make-mutex :name "register-thread"))) + + (defimplementation register-thread (name thread) + (declare (type symbol name)) + (sb-thread:with-mutex (mutex) + (etypecase thread + (null + (setf alist (delete name alist :key #'car))) + (sb-thread:thread + (let ((probe (assoc name alist))) + (cond (probe (setf (cdr probe) thread)) + (t (setf alist (acons name thread alist)))))))) + nil) + + (defimplementation find-registered (name) + (sb-thread:with-mutex (mutex) + (cdr (assoc name alist))))) + + ;; Workaround for deadlocks between the world-lock and auto-flush-thread + ;; buffer write lock. + ;; + ;; Another alternative would be to grab the world-lock here, but that's less + ;; future-proof, and could introduce other lock-ordering issues in the + ;; future. + ;; + ;; In an ideal world we would just have an :AROUND method on + ;; SLIME-OUTPUT-STREAM, and be done, but that class doesn't exist when this + ;; file is loaded -- so first we need a dummy definition that will be + ;; overridden by swank-gray.lisp. + #.(unless (find-package 'swank/gray) (make-package 'swank/gray) nil) + (eval-when (:load-toplevel :execute) + (unless (find-package 'swank/gray) (make-package 'swank/gray) nil)) + (defclass swank/gray::slime-output-stream + (sb-gray:fundamental-character-output-stream) + ()) + (defmethod sb-gray:stream-force-output + :around ((stream swank/gray::slime-output-stream)) + (handler-case + (sb-sys:with-deadline (:seconds 0.1) + (call-next-method)) + (sb-sys:deadline-timeout () + nil))) + ) + +(defimplementation quit-lisp () + #+#.(swank/backend:with-symbol 'exit 'sb-ext) + (sb-ext:exit) + #-#.(swank/backend:with-symbol 'exit 'sb-ext) + (progn + #+sb-thread + (dolist (thread (remove (current-thread) (all-threads))) + (ignore-errors (sb-thread:terminate-thread thread))) + (sb-ext:quit))) + + + +;;Trace implementations +;;In SBCL, we have: +;; (trace <name>) +;; (trace :methods '<name>) ;to trace all methods of the gf <name> +;; (trace (method <name> <qualifier>? (<specializer>+))) +;; <name> can be a normal name or a (setf name) + +(defun toggle-trace-aux (fspec &rest args) + (cond ((member fspec (eval '(trace)) :test #'equal) + (eval `(untrace ,fspec)) + (format nil "~S is now untraced." fspec)) + (t + (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args)) + (format nil "~S is now traced." fspec)))) + +(defun process-fspec (fspec) + (cond ((consp fspec) + (ecase (first fspec) + ((:defun :defgeneric) (second fspec)) + ((:defmethod) `(method ,@(rest fspec))) + ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec))) + ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec))))) + (t + fspec))) + +(defimplementation toggle-trace (spec) + (ecase (car spec) + ((setf) + (toggle-trace-aux spec)) + ((:defmethod) + (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec))))) + ((:defgeneric) + (toggle-trace-aux (second spec) :methods t)) + ((:call) + (destructuring-bind (caller callee) (cdr spec) + (toggle-trace-aux callee :wherein (list (process-fspec caller))))))) + +;;; Weak datastructures + +(defimplementation make-weak-key-hash-table (&rest args) + #+#.(swank/sbcl::sbcl-with-weak-hash-tables) + (apply #'make-hash-table :weakness :key args) + #-#.(swank/sbcl::sbcl-with-weak-hash-tables) + (apply #'make-hash-table args)) + +(defimplementation make-weak-value-hash-table (&rest args) + #+#.(swank/sbcl::sbcl-with-weak-hash-tables) + (apply #'make-hash-table :weakness :value args) + #-#.(swank/sbcl::sbcl-with-weak-hash-tables) + (apply #'make-hash-table args)) + +(defimplementation hash-table-weakness (hashtable) + #+#.(swank/sbcl::sbcl-with-weak-hash-tables) + (sb-ext:hash-table-weakness hashtable)) + +#-win32 +(defimplementation save-image (filename &optional restart-function) + (flet ((restart-sbcl () + (sb-debug::enable-debugger) + (setf sb-impl::*descriptor-handlers* nil) + (funcall restart-function))) + (let ((pid (sb-posix:fork))) + (cond ((= pid 0) + (sb-debug::disable-debugger) + (apply #'sb-ext:save-lisp-and-die filename + (when restart-function + (list :toplevel #'restart-sbcl)))) + (t + (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0) + (assert (= pid rpid)) + (assert (and (sb-posix:wifexited status) + (zerop (sb-posix:wexitstatus status)))))))))) + +#+unix +(progn + (sb-alien:define-alien-routine ("execv" sys-execv) sb-alien:int + (program sb-alien:c-string) + (argv (* sb-alien:c-string))) + + (defun execv (program args) + "Replace current executable with another one." + (let ((a-args (sb-alien:make-alien sb-alien:c-string + (+ 1 (length args))))) + (unwind-protect + (progn + (loop for index from 0 by 1 + and item in (append args '(nil)) + do (setf (sb-alien:deref a-args index) + item)) + (when (minusp + (sys-execv program a-args)) + (error "execv(3) returned."))) + (sb-alien:free-alien a-args)))) + + (defun runtime-pathname () + #+#.(swank/backend:with-symbol + '*runtime-pathname* 'sb-ext) + sb-ext:*runtime-pathname* + #-#.(swank/backend:with-symbol + '*runtime-pathname* 'sb-ext) + (car sb-ext:*posix-argv*)) + + (defimplementation exec-image (image-file args) + (loop with fd-arg = + (loop for arg in args + and key = "" then arg + when (string-equal key "--swank-fd") + return (parse-integer arg)) + for my-fd from 3 to 1024 + when (/= my-fd fd-arg) + do (ignore-errors (sb-posix:fcntl my-fd sb-posix:f-setfd 1))) + (let* ((self-string (pathname-to-filename (runtime-pathname)))) + (execv + self-string + (apply 'list self-string "--core" image-file args))))) + +(defimplementation make-fd-stream (fd external-format) + (sb-sys:make-fd-stream fd :input t :output t + :element-type 'character + :buffering :full + :dual-channel-p t + :external-format external-format)) + +#-win32 +(defimplementation background-save-image (filename &key restart-function + completion-function) + (flet ((restart-sbcl () + (sb-debug::enable-debugger) + (setf sb-impl::*descriptor-handlers* nil) + (funcall restart-function))) + (multiple-value-bind (pipe-in pipe-out) (sb-posix:pipe) + (let ((pid (sb-posix:fork))) + (cond ((= pid 0) + (sb-posix:close pipe-in) + (sb-debug::disable-debugger) + (apply #'sb-ext:save-lisp-and-die filename + (when restart-function + (list :toplevel #'restart-sbcl)))) + (t + (sb-posix:close pipe-out) + (sb-sys:add-fd-handler + pipe-in :input + (lambda (fd) + (sb-sys:invalidate-descriptor fd) + (sb-posix:close fd) + (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0) + (assert (= pid rpid)) + (assert (sb-posix:wifexited status)) + (funcall completion-function + (zerop (sb-posix:wexitstatus status)))))))))))) + +(pushnew 'deinit-log-output sb-ext:*save-hooks*) + + +;;;; wrap interface implementation + +(defun sbcl-version>= (&rest subversions) + #+#.(swank/backend:with-symbol 'assert-version->= 'sb-ext) + (values (ignore-errors (apply #'sb-ext:assert-version->= subversions) t)) + #-#.(swank/backend:with-symbol 'assert-version->= 'sb-ext) + nil) + +(defimplementation wrap (spec indicator &key before after replace) + (when (wrapped-p spec indicator) + (warn "~a already wrapped with indicator ~a, unwrapping first" + spec indicator) + (sb-int:unencapsulate spec indicator)) + (sb-int:encapsulate spec indicator + #-#.(swank/backend:with-symbol 'arg-list 'sb-int) + (lambda (function &rest args) + (sbcl-wrap spec before after replace function args)) + #+#.(swank/backend:with-symbol 'arg-list 'sb-int) + (if (sbcl-version>= 1 1 16) + (lambda () + (sbcl-wrap spec before after replace + (symbol-value 'sb-int:basic-definition) + (symbol-value 'sb-int:arg-list))) + `(sbcl-wrap ',spec ,before ,after ,replace + (symbol-value 'sb-int:basic-definition) + (symbol-value 'sb-int:arg-list))))) + +(defimplementation unwrap (spec indicator) + (sb-int:unencapsulate spec indicator)) + +(defimplementation wrapped-p (spec indicator) + (sb-int:encapsulated-p spec indicator)) + +(defun sbcl-wrap (spec before after replace function args) + (declare (ignore spec)) + (let (retlist completed) + (unwind-protect + (progn + (when before + (funcall before args)) + (setq retlist (multiple-value-list (if replace + (funcall replace + args) + (apply function args)))) + (setq completed t) + (values-list retlist)) + (when after + (funcall after (if completed retlist :exited-non-locally)))))) + +#+#.(swank/backend:with-symbol 'comma-expr 'sb-impl) +(progn + (defmethod sexp-in-bounds-p ((s sb-impl::comma) i) + (= i 1)) + + (defmethod sexp-ref ((s sb-impl::comma) i) + (sb-impl::comma-expr s))) diff --git a/vim/bundle/slimv/slime/swank/scl.lisp b/vim/bundle/slimv/slime/swank/scl.lisp new file mode 100644 index 0000000..7327133 --- /dev/null +++ b/vim/bundle/slimv/slime/swank/scl.lisp @@ -0,0 +1,1726 @@ +;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*- +;;; +;;; Scieneer Common Lisp code for SLIME. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(defpackage swank/scl + (:use cl swank/backend swank/source-path-parser swank/source-file-cache)) + +(in-package swank/scl) + + + +;;; swank-mop + +(import-swank-mop-symbols :clos '(:slot-definition-documentation)) + +(defun swank-mop:slot-definition-documentation (slot) + (documentation slot t)) + + +;;;; TCP server +;;; +;;; SCL only supports the :spawn communication style. +;;; + +(defimplementation preferred-communication-style () + :spawn) + +(defimplementation create-socket (host port &key backlog) + (let ((addr (resolve-hostname host))) + (ext:create-inet-listener port :stream :host addr :reuse-address t + :backlog (or backlog 5)))) + +(defimplementation local-port (socket) + (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket)))) + +(defimplementation close-socket (socket) + (ext:close-socket (socket-fd socket))) + +(defimplementation accept-connection (socket + &key external-format buffering timeout) + (let ((buffering (or buffering :full)) + (fd (socket-fd socket))) + (loop + (let ((ready (sys:wait-until-fd-usable fd :input timeout))) + (unless ready + (error "Timeout accepting connection on socket: ~S~%" socket))) + (let ((new-fd (ignore-errors (ext:accept-tcp-connection fd)))) + (when new-fd + (return (make-socket-io-stream new-fd external-format + (ecase buffering + ((t) :full) + ((nil) :none) + (:line :line))))))))) + +(defimplementation set-stream-timeout (stream timeout) + (check-type timeout (or null real)) + (if (fboundp 'ext::stream-timeout) + (setf (ext::stream-timeout stream) timeout) + (setf (slot-value (slot-value stream 'lisp::stream) 'lisp::timeout) + timeout))) + +;;;;; Sockets + +(defun socket-fd (socket) + "Return the file descriptor for the socket represented by 'socket." + (etypecase socket + (fixnum socket) + (stream (sys:fd-stream-fd socket)))) + +(defun resolve-hostname (hostname) + "Return the IP address of 'hostname as an integer (in host byte-order)." + (let ((hostent (ext:lookup-host-entry hostname))) + (car (ext:host-entry-addr-list hostent)))) + +(defvar *external-format-to-coding-system* + '((:iso-8859-1 + "latin-1" "latin-1-unix" "iso-latin-1-unix" + "iso-8859-1" "iso-8859-1-unix") + (:utf-8 "utf-8" "utf-8-unix") + (:euc-jp "euc-jp" "euc-jp-unix"))) + +(defimplementation find-external-format (coding-system) + (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + +(defun make-socket-io-stream (fd external-format buffering) + "Create a new input/output fd-stream for 'fd." + (cond ((not external-format) + (sys:make-fd-stream fd :input t :output t :buffering buffering + :element-type '(unsigned-byte 8))) + (t + (let* ((stream (sys:make-fd-stream fd :input t :output t + :element-type 'base-char + :buffering buffering + :external-format external-format))) + ;; Ignore character conversion errors. Without this the + ;; communication channel is prone to lockup if a character + ;; conversion error occurs. + (setf (lisp::character-conversion-stream-input-error-value stream) + #\?) + (setf (lisp::character-conversion-stream-output-error-value stream) + #\?) + stream)))) + + +;;;; Stream handling + +(defimplementation gray-package-name () + '#:ext) + + +;;;; Compilation Commands + +(defvar *previous-compiler-condition* nil + "Used to detect duplicates.") + +(defvar *previous-context* nil + "Previous compiler error context.") + +(defvar *buffer-name* nil + "The name of the Emacs buffer we are compiling from. + Nil if we aren't compiling from a buffer.") + +(defvar *buffer-start-position* nil) +(defvar *buffer-substring* nil) + +(defimplementation call-with-compilation-hooks (function) + (let ((*previous-compiler-condition* nil) + (*previous-context* nil) + (*print-readably* nil)) + (handler-bind ((c::compiler-error #'handle-notification-condition) + (c::style-warning #'handle-notification-condition) + (c::warning #'handle-notification-condition)) + (funcall function)))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (with-compilation-hooks () + (let ((*buffer-name* nil) + (ext:*ignore-extra-close-parentheses* nil)) + (multiple-value-bind (output-file warnings-p failure-p) + (compile-file input-file + :output-file output-file + :external-format external-format) + (values output-file warnings-p + (or failure-p + (when load-p + ;; Cache the latest source file for definition-finding. + (source-cache-get input-file + (file-write-date input-file)) + (not (load output-file))))))))) + +(defimplementation swank-compile-string (string &key buffer position filename + policy) + (declare (ignore filename policy)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-start-position* position) + (*buffer-substring* string)) + (with-input-from-string (stream string) + (ext:compile-from-stream + stream + :source-info `(:emacs-buffer ,buffer + :emacs-buffer-offset ,position + :emacs-buffer-string ,string)))))) + + +;;;;; Trapping notes +;;; +;;; We intercept conditions from the compiler and resignal them as +;;; `swank:compiler-condition's. + +(defun handle-notification-condition (condition) + "Handle a condition caused by a compiler warning." + (unless (eq condition *previous-compiler-condition*) + (let ((context (c::find-error-context nil))) + (setq *previous-compiler-condition* condition) + (setq *previous-context* context) + (signal-compiler-condition condition context)))) + +(defun signal-compiler-condition (condition context) + (signal 'compiler-condition + :original-condition condition + :severity (severity-for-emacs condition) + :message (brief-compiler-message-for-emacs condition) + :source-context (compiler-error-context context) + :location (if (read-error-p condition) + (read-error-location condition) + (compiler-note-location context)))) + +(defun severity-for-emacs (condition) + "Return the severity of 'condition." + (etypecase condition + ((satisfies read-error-p) :read-error) + (c::compiler-error :error) + (c::style-warning :note) + (c::warning :warning))) + +(defun read-error-p (condition) + (eq (type-of condition) 'c::compiler-read-error)) + +(defun brief-compiler-message-for-emacs (condition) + "Briefly describe a compiler error for Emacs. + When Emacs presents the message it already has the source popped up + and the source form highlighted. This makes much of the information in + the error-context redundant." + (princ-to-string condition)) + +(defun compiler-error-context (error-context) + "Describe a compiler error for Emacs including context information." + (declare (type (or c::compiler-error-context null) error-context)) + (multiple-value-bind (enclosing source) + (if error-context + (values (c::compiler-error-context-enclosing-source error-context) + (c::compiler-error-context-source error-context))) + (if (and enclosing source) + (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~^~%~}~]" + enclosing source)))) + +(defun read-error-location (condition) + (let* ((finfo (car (c::source-info-current-file c::*source-info*))) + (file (c::file-info-name finfo)) + (pos (c::compiler-read-error-position condition))) + (cond ((and (eq file :stream) *buffer-name*) + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-start-position* pos))) + ((and (pathnamep file) (not *buffer-name*)) + (make-location (list :file (unix-truename file)) + (list :position (1+ pos)))) + (t (break))))) + +(defun compiler-note-location (context) + "Derive the location of a complier message from its context. + Return a `location' record, or (:error <reason>) on failure." + (if (null context) + (note-error-location) + (let ((file (c::compiler-error-context-file-name context)) + (source (c::compiler-error-context-original-source context)) + (path + (reverse + (c::compiler-error-context-original-source-path context)))) + (or (locate-compiler-note file source path) + (note-error-location))))) + +(defun note-error-location () + "Pseudo-location for notes that can't be located." + (list :error "No error location available.")) + +(defun locate-compiler-note (file source source-path) + (cond ((and (eq file :stream) *buffer-name*) + ;; Compiling from a buffer + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-start-position* + (source-path-string-position + source-path *buffer-substring*)))) + ((and (pathnamep file) (null *buffer-name*)) + ;; Compiling from a file + (make-location (list :file (unix-truename file)) + (list :position (1+ (source-path-file-position + source-path file))))) + ((and (eq file :lisp) (stringp source)) + ;; No location known, but we have the source form. + ;; XXX How is this case triggered? -luke (16/May/2004) + ;; This can happen if the compiler needs to expand a macro + ;; but the macro-expander is not yet compiled. Calling the + ;; (interpreted) macro-expander triggers IR1 conversion of + ;; the lambda expression for the expander and invokes the + ;; compiler recursively. + (make-location (list :source-form source) + (list :position 1))))) + +(defun unix-truename (pathname) + (ext:unix-namestring (truename pathname))) + + + +;;; TODO +(defimplementation who-calls (name) nil) +(defimplementation who-references (name) nil) +(defimplementation who-binds (name) nil) +(defimplementation who-sets (name) nil) +(defimplementation who-specializes (symbol) nil) +(defimplementation who-macroexpands (name) nil) + + +;;;; Find callers and callees +;;; +;;; Find callers and callees by looking at the constant pool of +;;; compiled code objects. We assume every fdefn object in the +;;; constant pool corresponds to a call to that function. A better +;;; strategy would be to use the disassembler to find actual +;;; call-sites. + +(declaim (inline map-code-constants)) +(defun map-code-constants (code fn) + "Call 'fn for each constant in 'code's constant pool." + (check-type code kernel:code-component) + (loop for i from vm:code-constants-offset below (kernel:get-header-data code) + do (funcall fn (kernel:code-header-ref code i)))) + +(defun function-callees (function) + "Return 'function's callees as a list of functions." + (let ((callees '())) + (map-code-constants + (vm::find-code-object function) + (lambda (obj) + (when (kernel:fdefn-p obj) + (push (kernel:fdefn-function obj) callees)))) + callees)) + +(declaim (ext:maybe-inline map-allocated-code-components)) +(defun map-allocated-code-components (spaces fn) + "Call FN for each allocated code component in one of 'spaces. FN + receives the object as argument. 'spaces should be a list of the + symbols :dynamic, :static, or :read-only." + (dolist (space spaces) + (declare (inline vm::map-allocated-objects) + (optimize (ext:inhibit-warnings 3))) + (vm::map-allocated-objects + (lambda (obj header size) + (declare (type fixnum size) (ignore size)) + (when (= vm:code-header-type header) + (funcall fn obj))) + space))) + +(declaim (ext:maybe-inline map-caller-code-components)) +(defun map-caller-code-components (function spaces fn) + "Call 'fn for each code component with a fdefn for 'function in its + constant pool." + (let ((function (coerce function 'function))) + (declare (inline map-allocated-code-components)) + (map-allocated-code-components + spaces + (lambda (obj) + (map-code-constants + obj + (lambda (constant) + (when (and (kernel:fdefn-p constant) + (eq (kernel:fdefn-function constant) + function)) + (funcall fn obj)))))))) + +(defun function-callers (function &optional (spaces '(:read-only :static + :dynamic))) + "Return 'function's callers. The result is a list of code-objects." + (let ((referrers '())) + (declare (inline map-caller-code-components)) + (map-caller-code-components function spaces + (lambda (code) (push code referrers))) + referrers)) + +(defun debug-info-definitions (debug-info) + "Return the defintions for a debug-info. This should only be used + for code-object without entry points, i.e., byte compiled + code (are theree others?)" + ;; This mess has only been tested with #'ext::skip-whitespace, a + ;; byte-compiled caller of #'read-char . + (check-type debug-info (and (not c::compiled-debug-info) c::debug-info)) + (let ((name (c::debug-info-name debug-info)) + (source (c::debug-info-source debug-info))) + (destructuring-bind (first) source + (ecase (c::debug-source-from first) + (:file + (list (list name + (make-location + (list :file (unix-truename (c::debug-source-name first))) + (list :function-name (string name)))))))))) + +(defun valid-function-name-p (name) + (or (symbolp name) (and (consp name) + (eq (car name) 'setf) + (symbolp (cadr name)) + (not (cddr name))))) + +(defun code-component-entry-points (code) + "Return a list ((name location) ...) of function definitons for + the code omponent 'code." + (let ((names '())) + (do ((f (kernel:%code-entry-points code) (kernel::%function-next f))) + ((not f)) + (let ((name (kernel:%function-name f))) + (when (valid-function-name-p name) + (push (list name (function-location f)) names)))) + names)) + +(defimplementation list-callers (symbol) + "Return a list ((name location) ...) of callers." + (let ((components (function-callers symbol)) + (xrefs '())) + (dolist (code components) + (let* ((entry (kernel:%code-entry-points code)) + (defs (if entry + (code-component-entry-points code) + ;; byte compiled stuff + (debug-info-definitions + (kernel:%code-debug-info code))))) + (setq xrefs (nconc defs xrefs)))) + xrefs)) + +(defimplementation list-callees (symbol) + (let ((fns (function-callees symbol))) + (mapcar (lambda (fn) + (list (kernel:%function-name fn) + (function-location fn))) + fns))) + + +;;;; Resolving source locations +;;; +;;; Our mission here is to "resolve" references to code locations into +;;; actual file/buffer names and character positions. The references +;;; we work from come out of the compiler's statically-generated debug +;;; information, such as `code-location''s and `debug-source''s. For +;;; more details, see the "Debugger Programmer's Interface" section of +;;; the SCL manual. +;;; +;;; The first step is usually to find the corresponding "source-path" +;;; for the location. Once we have the source-path we can pull up the +;;; source file and `READ' our way through to the right position. The +;;; main source-code groveling work is done in +;;; `source-path-parser.lisp'. + +(defvar *debug-definition-finding* nil + "When true don't handle errors while looking for definitions. + This is useful when debugging the definition-finding code.") + +(defmacro safe-definition-finding (&body body) + "Execute 'body and return the source-location it returns. + If an error occurs and `*debug-definition-finding*' is false, then + return an error pseudo-location. + + The second return value is 'nil if no error occurs, otherwise it is the + condition object." + `(flet ((body () ,@body)) + (if *debug-definition-finding* + (body) + (handler-case (values (progn ,@body) nil) + (error (c) (values (list :error (princ-to-string c)) c)))))) + +(defun code-location-source-location (code-location) + "Safe wrapper around `code-location-from-source-location'." + (safe-definition-finding + (source-location-from-code-location code-location))) + +(defun source-location-from-code-location (code-location) + "Return the source location for 'code-location." + (let ((debug-fun (di:code-location-debug-function code-location))) + (when (di::bogus-debug-function-p debug-fun) + ;; Those lousy cheapskates! They've put in a bogus debug source + ;; because the code was compiled at a low debug setting. + (error "Bogus debug function: ~A" debug-fun))) + (let* ((debug-source (di:code-location-debug-source code-location)) + (from (di:debug-source-from debug-source)) + (name (di:debug-source-name debug-source))) + (ecase from + (:file + (location-in-file name code-location debug-source)) + (:stream + (location-in-stream code-location debug-source)) + (:lisp + ;; The location comes from a form passed to `compile'. + ;; The best we can do is return the form itself for printing. + (make-location + (list :source-form (with-output-to-string (*standard-output*) + (debug::print-code-location-source-form + code-location 100 t))) + (list :position 1)))))) + +(defun location-in-file (filename code-location debug-source) + "Resolve the source location for 'code-location in 'filename." + (let* ((code-date (di:debug-source-created debug-source)) + (source-code (get-source-code filename code-date))) + (with-input-from-string (s source-code) + (make-location (list :file (unix-truename filename)) + (list :position (1+ (code-location-stream-position + code-location s))) + `(:snippet ,(read-snippet s)))))) + +(defun location-in-stream (code-location debug-source) + "Resolve the source location for a 'code-location from a stream. + This only succeeds if the code was compiled from an Emacs buffer." + (unless (debug-source-info-from-emacs-buffer-p debug-source) + (error "The code is compiled from a non-SLIME stream.")) + (let* ((info (c::debug-source-info debug-source)) + (string (getf info :emacs-buffer-string)) + (position (code-location-string-offset + code-location + string))) + (make-location + (list :buffer (getf info :emacs-buffer)) + (list :offset (getf info :emacs-buffer-offset) position) + (list :snippet (with-input-from-string (s string) + (file-position s position) + (read-snippet s)))))) + +;;;;; Function-name locations +;;; +(defun debug-info-function-name-location (debug-info) + "Return a function-name source-location for 'debug-info. + Function-name source-locations are a fallback for when precise + positions aren't available." + (with-struct (c::debug-info- (fname name) source) debug-info + (with-struct (c::debug-source- info from name) (car source) + (ecase from + (:file + (make-location (list :file (namestring (truename name))) + (list :function-name (string fname)))) + (:stream + (assert (debug-source-info-from-emacs-buffer-p (car source))) + (make-location (list :buffer (getf info :emacs-buffer)) + (list :function-name (string fname)))) + (:lisp + (make-location (list :source-form (princ-to-string (aref name 0))) + (list :position 1))))))) + +(defun debug-source-info-from-emacs-buffer-p (debug-source) + "Does the `info' slot of 'debug-source contain an Emacs buffer location? + This is true for functions that were compiled directly from buffers." + (info-from-emacs-buffer-p (c::debug-source-info debug-source))) + +(defun info-from-emacs-buffer-p (info) + (and info + (consp info) + (eq :emacs-buffer (car info)))) + + +;;;;; Groveling source-code for positions + +(defun code-location-stream-position (code-location stream) + "Return the byte offset of 'code-location in 'stream. Extract the + toplevel-form-number and form-number from 'code-location and use that + to find the position of the corresponding form. + + Finish with 'stream positioned at the start of the code location." + (let* ((location (debug::maybe-block-start-location code-location)) + (tlf-offset (di:code-location-top-level-form-offset location)) + (form-number (di:code-location-form-number location))) + (let ((pos (form-number-stream-position tlf-offset form-number stream))) + (file-position stream pos) + pos))) + +(defun form-number-stream-position (tlf-number form-number stream) + "Return the starting character position of a form in 'stream. + 'tlf-number is the top-level-form number. + 'form-number is an index into a source-path table for the TLF." + (multiple-value-bind (tlf position-map) (read-source-form tlf-number stream) + (let* ((path-table (di:form-number-translations tlf 0)) + (source-path + (if (<= (length path-table) form-number) ; source out of sync? + (list 0) ; should probably signal a condition + (reverse (cdr (aref path-table form-number)))))) + (source-path-source-position source-path tlf position-map)))) + +(defun code-location-string-offset (code-location string) + "Return the byte offset of 'code-location in 'string. + See 'code-location-stream-position." + (with-input-from-string (s string) + (code-location-stream-position code-location s))) + + +;;;; Finding definitions + +;;; There are a great many different types of definition for us to +;;; find. We search for definitions of every kind and return them in a +;;; list. + +(defimplementation find-definitions (name) + (append (function-definitions name) + (setf-definitions name) + (variable-definitions name) + (class-definitions name) + (type-definitions name) + (compiler-macro-definitions name) + (source-transform-definitions name) + (function-info-definitions name) + (ir1-translator-definitions name))) + +;;;;; Functions, macros, generic functions, methods +;;; +;;; We make extensive use of the compile-time debug information that +;;; SCL records, in particular "debug functions" and "code +;;; locations." Refer to the "Debugger Programmer's Interface" section +;;; of the SCL manual for more details. + +(defun function-definitions (name) + "Return definitions for 'name in the \"function namespace\", i.e., + regular functions, generic functions, methods and macros. + 'name can any valid function name (e.g, (setf car))." + (let ((macro? (and (symbolp name) (macro-function name))) + (special? (and (symbolp name) (special-operator-p name))) + (function? (and (valid-function-name-p name) + (ext:info :function :definition name) + (if (symbolp name) (fboundp name) t)))) + (cond (macro? + (list `((defmacro ,name) + ,(function-location (macro-function name))))) + (special? + (list `((:special-operator ,name) + (:error ,(format nil "Special operator: ~S" name))))) + (function? + (let ((function (fdefinition name))) + (if (genericp function) + (generic-function-definitions name function) + (list (list `(function ,name) + (function-location function))))))))) + +;;;;;; Ordinary (non-generic/macro/special) functions +;;; +;;; First we test if FUNCTION is a closure created by defstruct, and +;;; if so extract the defstruct-description (`dd') from the closure +;;; and find the constructor for the struct. Defstruct creates a +;;; defun for the default constructor and we use that as an +;;; approximation to the source location of the defstruct. +;;; +;;; For an ordinary function we return the source location of the +;;; first code-location we find. +;;; +(defun function-location (function) + "Return the source location for FUNCTION." + (cond ((struct-closure-p function) + (struct-closure-location function)) + ((c::byte-function-or-closure-p function) + (byte-function-location function)) + (t + (compiled-function-location function)))) + +(defun compiled-function-location (function) + "Return the location of a regular compiled function." + (multiple-value-bind (code-location error) + (safe-definition-finding (function-first-code-location function)) + (cond (error (list :error (princ-to-string error))) + (t (code-location-source-location code-location))))) + +(defun function-first-code-location (function) + "Return the first code-location we can find for 'function." + (and (function-has-debug-function-p function) + (di:debug-function-start-location + (di:function-debug-function function)))) + +(defun function-has-debug-function-p (function) + (di:function-debug-function function)) + +(defun function-code-object= (closure function) + (and (eq (vm::find-code-object closure) + (vm::find-code-object function)) + (not (eq closure function)))) + + +(defun byte-function-location (fn) + "Return the location of the byte-compiled function 'fn." + (etypecase fn + ((or c::hairy-byte-function c::simple-byte-function) + (let* ((component (c::byte-function-component fn)) + (debug-info (kernel:%code-debug-info component))) + (debug-info-function-name-location debug-info))) + (c::byte-closure + (byte-function-location (c::byte-closure-function fn))))) + +;;; Here we deal with structure accessors. Note that `dd' is a +;;; "defstruct descriptor" structure in SCL. A `dd' describes a +;;; `defstruct''d structure. + +(defun struct-closure-p (function) + "Is 'function a closure created by defstruct?" + (or (function-code-object= function #'kernel::structure-slot-accessor) + (function-code-object= function #'kernel::structure-slot-setter) + (function-code-object= function #'kernel::%defstruct))) + +(defun struct-closure-location (function) + "Return the location of the structure that 'function belongs to." + (assert (struct-closure-p function)) + (safe-definition-finding + (dd-location (struct-closure-dd function)))) + +(defun struct-closure-dd (function) + "Return the defstruct-definition (dd) of FUNCTION." + (assert (= (kernel:get-type function) vm:closure-header-type)) + (flet ((find-layout (function) + (sys:find-if-in-closure + (lambda (x) + (let ((value (if (di::indirect-value-cell-p x) + (c:value-cell-ref x) + x))) + (when (kernel::layout-p value) + (return-from find-layout value)))) + function))) + (kernel:layout-info (find-layout function)))) + +(defun dd-location (dd) + "Return the location of a `defstruct'." + ;; Find the location in a constructor. + (function-location (struct-constructor dd))) + +(defun struct-constructor (dd) + "Return a constructor function from a defstruct definition. +Signal an error if no constructor can be found." + (let ((constructor (or (kernel:dd-default-constructor dd) + (car (kernel::dd-constructors dd))))) + (when (or (null constructor) + (and (consp constructor) (null (car constructor)))) + (error "Cannot find structure's constructor: ~S" + (kernel::dd-name dd))) + (coerce (if (consp constructor) (first constructor) constructor) + 'function))) + +;;;;;; Generic functions and methods + +(defun generic-function-definitions (name function) + "Return the definitions of a generic function and its methods." + (cons (list `(defgeneric ,name) (gf-location function)) + (gf-method-definitions function))) + +(defun gf-location (gf) + "Return the location of the generic function GF." + (definition-source-location gf (clos:generic-function-name gf))) + +(defun gf-method-definitions (gf) + "Return the locations of all methods of the generic function GF." + (mapcar #'method-definition (clos:generic-function-methods gf))) + +(defun method-definition (method) + (list (method-dspec method) + (method-location method))) + +(defun method-dspec (method) + "Return a human-readable \"definition specifier\" for METHOD." + (let* ((gf (clos:method-generic-function method)) + (name (clos:generic-function-name gf)) + (specializers (clos:method-specializers method)) + (qualifiers (clos:method-qualifiers method))) + `(method ,name ,@qualifiers ,specializers + #+nil (clos::unparse-specializers specializers)))) + +;; XXX maybe special case setters/getters +(defun method-location (method) + (function-location (clos:method-function method))) + +(defun genericp (fn) + (typep fn 'generic-function)) + +;;;;;; Types and classes + +(defun type-definitions (name) + "Return `deftype' locations for type NAME." + (maybe-make-definition (ext:info :type :expander name) 'deftype name)) + +(defun maybe-make-definition (function kind name) + "If FUNCTION is non-nil then return its definition location." + (if function + (list (list `(,kind ,name) (function-location function))))) + +(defun class-definitions (name) + "Return the definition locations for the class called NAME." + (if (symbolp name) + (let ((class (find-class name nil))) + (etypecase class + (null '()) + (structure-class + (list (list `(defstruct ,name) + (dd-location (find-dd name))))) + (standard-class + (list (list `(defclass ,name) + (class-location (find-class name))))) + ((or built-in-class + kernel:funcallable-structure-class) + (list (list `(kernel::define-type-class ,name) + `(:error + ,(format nil "No source info for ~A" name))))))))) + +(defun class-location (class) + "Return the `defclass' location for CLASS." + (definition-source-location class (class-name class))) + +(defun find-dd (name) + "Find the defstruct-definition by the name of its structure-class." + (let ((layout (ext:info :type :compiler-layout name))) + (if layout + (kernel:layout-info layout)))) + +(defun condition-class-location (class) + (let ((name (class-name class))) + `(:error ,(format nil "No location info for condition: ~A" name)))) + +(defun make-name-in-file-location (file string) + (multiple-value-bind (filename c) + (ignore-errors + (unix-truename (merge-pathnames (make-pathname :type "lisp") + file))) + (cond (filename (make-location `(:file ,filename) + `(:function-name ,(string string)))) + (t (list :error (princ-to-string c)))))) + +(defun definition-source-location (object name) + `(:error ,(format nil "No source info for: ~A" object))) + +(defun setf-definitions (name) + (let ((function (or (ext:info :setf :inverse name) + (ext:info :setf :expander name)))) + (if function + (list (list `(setf ,name) + (function-location (coerce function 'function))))))) + + +(defun variable-location (symbol) + `(:error ,(format nil "No source info for variable ~S" symbol))) + +(defun variable-definitions (name) + (if (symbolp name) + (multiple-value-bind (kind recorded-p) (ext:info :variable :kind name) + (if recorded-p + (list (list `(variable ,kind ,name) + (variable-location name))))))) + +(defun compiler-macro-definitions (symbol) + (maybe-make-definition (compiler-macro-function symbol) + 'define-compiler-macro + symbol)) + +(defun source-transform-definitions (name) + (maybe-make-definition (ext:info :function :source-transform name) + 'c:def-source-transform + name)) + +(defun function-info-definitions (name) + (let ((info (ext:info :function :info name))) + (if info + (append (loop for transform in (c::function-info-transforms info) + collect (list `(c:deftransform ,name + ,(c::type-specifier + (c::transform-type transform))) + (function-location (c::transform-function + transform)))) + (maybe-make-definition (c::function-info-derive-type info) + 'c::derive-type name) + (maybe-make-definition (c::function-info-optimizer info) + 'c::optimizer name) + (maybe-make-definition (c::function-info-ltn-annotate info) + 'c::ltn-annotate name) + (maybe-make-definition (c::function-info-ir2-convert info) + 'c::ir2-convert name) + (loop for template in (c::function-info-templates info) + collect (list `(c::vop ,(c::template-name template)) + (function-location + (c::vop-info-generator-function + template)))))))) + +(defun ir1-translator-definitions (name) + (maybe-make-definition (ext:info :function :ir1-convert name) + 'c:def-ir1-translator name)) + + +;;;; Documentation. + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind) + (or (documentation symbol kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (multiple-value-bind (kind recorded-p) + (ext:info variable kind symbol) + (declare (ignore kind)) + (if (or (boundp symbol) recorded-p) + (doc 'variable)))) + (when (fboundp symbol) + (maybe-push + (cond ((macro-function symbol) :macro) + ((special-operator-p symbol) :special-operator) + ((genericp (fdefinition symbol)) :generic-function) + (t :function)) + (doc 'function))) + (maybe-push + :setf (if (or (ext:info setf inverse symbol) + (ext:info setf expander symbol)) + (doc 'setf))) + (maybe-push + :type (if (ext:info type kind symbol) + (doc 'type))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + (maybe-push + :alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown)) + (doc 'alien-type))) + (maybe-push + :alien-struct (if (ext:info alien-type struct symbol) + (doc nil))) + (maybe-push + :alien-union (if (ext:info alien-type union symbol) + (doc nil))) + (maybe-push + :alien-enum (if (ext:info alien-type enum symbol) + (doc nil))) + result))) + +(defimplementation describe-definition (symbol namespace) + (describe (ecase namespace + (:variable + symbol) + ((:function :generic-function) + (symbol-function symbol)) + (:setf + (or (ext:info setf inverse symbol) + (ext:info setf expander symbol))) + (:type + (kernel:values-specifier-type symbol)) + (:class + (find-class symbol)) + (:alien-struct + (ext:info :alien-type :struct symbol)) + (:alien-union + (ext:info :alien-type :union symbol)) + (:alien-enum + (ext:info :alien-type :enum symbol)) + (:alien-type + (ecase (ext:info :alien-type :kind symbol) + (:primitive + (let ((alien::*values-type-okay* t)) + (funcall (ext:info :alien-type :translator symbol) + (list symbol)))) + ((:defined) + (ext:info :alien-type :definition symbol)) + (:unknown :unknown)))))) + +;;;;; Argument lists + +(defimplementation arglist (fun) + (multiple-value-bind (args winp) + (ext:function-arglist fun) + (if winp args :not-available))) + +(defimplementation function-name (function) + (cond ((eval:interpreted-function-p function) + (eval:interpreted-function-name function)) + ((typep function 'generic-function) + (clos:generic-function-name function)) + ((c::byte-function-or-closure-p function) + (c::byte-function-name function)) + (t (kernel:%function-name (kernel:%function-self function))))) + + +;;; A harder case: an approximate arglist is derived from available +;;; debugging information. + +(defun debug-function-arglist (debug-function) + "Derive the argument list of DEBUG-FUNCTION from debug info." + (let ((args (di::debug-function-lambda-list debug-function)) + (required '()) + (optional '()) + (rest '()) + (key '())) + ;; collect the names of debug-vars + (dolist (arg args) + (etypecase arg + (di::debug-variable + (push (di::debug-variable-symbol arg) required)) + ((member :deleted) + (push ':deleted required)) + (cons + (ecase (car arg) + (:keyword + (push (second arg) key)) + (:optional + (push (debug-variable-symbol-or-deleted (second arg)) optional)) + (:rest + (push (debug-variable-symbol-or-deleted (second arg)) rest)))))) + ;; intersperse lambda keywords as needed + (append (nreverse required) + (if optional (cons '&optional (nreverse optional))) + (if rest (cons '&rest (nreverse rest))) + (if key (cons '&key (nreverse key)))))) + +(defun debug-variable-symbol-or-deleted (var) + (etypecase var + (di:debug-variable + (di::debug-variable-symbol var)) + ((member :deleted) + '#:deleted))) + +(defun symbol-debug-function-arglist (fname) + "Return FNAME's debug-function-arglist and %function-arglist. + A utility for debugging DEBUG-FUNCTION-ARGLIST." + (let ((fn (fdefinition fname))) + (values (debug-function-arglist (di::function-debug-function fn)) + (kernel:%function-arglist (kernel:%function-self fn))))) + + +;;;; Miscellaneous. + +(defimplementation macroexpand-all (form &optional env) + (declare (ignore env)) + (macroexpand form)) + +(defimplementation set-default-directory (directory) + (setf (ext:default-directory) (namestring directory)) + ;; Setting *default-pathname-defaults* to an absolute directory + ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive. + (setf *default-pathname-defaults* (pathname (ext:default-directory))) + (default-directory)) + +(defimplementation default-directory () + (namestring (ext:default-directory))) + +(defimplementation pathname-to-filename (pathname) + (ext:unix-namestring pathname nil)) + +(defimplementation getpid () + (unix:unix-getpid)) + +(defimplementation lisp-implementation-type-name () + (if (eq ext:*case-mode* :upper) "scl" "scl-lower")) + +(defimplementation quit-lisp () + (ext:quit)) + +;;; source-path-{stream,file,string,etc}-position moved into +;;; source-path-parser + + +;;;; Debugging + +(defvar *sldb-stack-top*) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame))) + (debug:*stack-top-hint* nil) + (kernel:*current-level* 0)) + (handler-bind ((di::unhandled-condition + (lambda (condition) + (error 'sldb-condition + :original-condition condition)))) + (funcall debugger-loop-fn)))) + +(defun frame-down (frame) + (handler-case (di:frame-down frame) + (di:no-debug-info () nil))) + +(defun nth-frame (index) + (do ((frame *sldb-stack-top* (frame-down frame)) + (i index (1- i))) + ((zerop i) frame))) + +(defimplementation compute-backtrace (start end) + (let ((end (or end most-positive-fixnum))) + (loop for f = (nth-frame start) then (frame-down f) + for i from start below end + while f collect f))) + +(defimplementation print-frame (frame stream) + (let ((*standard-output* stream)) + (handler-case + (debug::print-frame-call frame :verbosity 1 :number nil) + (error (e) + (ignore-errors (princ e stream)))))) + +(defimplementation frame-source-location (index) + (code-location-source-location (di:frame-code-location (nth-frame index)))) + +(defimplementation eval-in-frame (form index) + (di:eval-in-frame (nth-frame index) form)) + +(defun frame-debug-vars (frame) + "Return a vector of debug-variables in frame." + (di::debug-function-debug-variables (di:frame-debug-function frame))) + +(defun debug-var-value (var frame location) + (let ((validity (di:debug-variable-validity var location))) + (ecase validity + (:valid (di:debug-variable-value var frame)) + ((:invalid :unknown) (make-symbol (string validity)))))) + +(defimplementation frame-locals (index) + (let* ((frame (nth-frame index)) + (loc (di:frame-code-location frame)) + (vars (frame-debug-vars frame))) + (loop for v across vars collect + (list :name (di:debug-variable-symbol v) + :id (di:debug-variable-id v) + :value (debug-var-value v frame loc))))) + +(defimplementation frame-var-value (frame var) + (let* ((frame (nth-frame frame)) + (dvar (aref (frame-debug-vars frame) var))) + (debug-var-value dvar frame (di:frame-code-location frame)))) + +(defimplementation frame-catch-tags (index) + (mapcar #'car (di:frame-catches (nth-frame index)))) + +(defimplementation return-from-frame (index form) + (let ((sym (find-symbol (symbol-name '#:find-debug-tag-for-frame) + :debug-internals))) + (if sym + (let* ((frame (nth-frame index)) + (probe (funcall sym frame))) + (cond (probe (throw (car probe) (eval-in-frame form index))) + (t (format nil "Cannot return from frame: ~S" frame)))) + "return-from-frame is not implemented in this version of SCL."))) + +(defimplementation activate-stepping (frame) + (set-step-breakpoints (nth-frame frame))) + +(defimplementation sldb-break-on-return (frame) + (break-on-return (nth-frame frame))) + +;;; We set the breakpoint in the caller which might be a bit confusing. +;;; +(defun break-on-return (frame) + (let* ((caller (di:frame-down frame)) + (cl (di:frame-code-location caller))) + (flet ((hook (frame bp) + (when (frame-pointer= frame caller) + (di:delete-breakpoint bp) + (signal-breakpoint bp frame)))) + (let* ((info (ecase (di:code-location-kind cl) + ((:single-value-return :unknown-return) nil) + (:known-return (debug-function-returns + (di:frame-debug-function frame))))) + (bp (di:make-breakpoint #'hook cl :kind :code-location + :info info))) + (di:activate-breakpoint bp) + `(:ok ,(format nil "Set breakpoint in ~A" caller)))))) + +(defun frame-pointer= (frame1 frame2) + "Return true if the frame pointers of FRAME1 and FRAME2 are the same." + (sys:sap= (di::frame-pointer frame1) (di::frame-pointer frame2))) + +;;; The PC in escaped frames at a single-return-value point is +;;; actually vm:single-value-return-byte-offset bytes after the +;;; position given in the debug info. Here we try to recognize such +;;; cases. +;;; +(defun next-code-locations (frame code-location) + "Like `debug::next-code-locations' but be careful in escaped frames." + (let ((next (debug::next-code-locations code-location))) + (flet ((adjust-pc () + (let ((cl (di::copy-compiled-code-location code-location))) + (incf (di::compiled-code-location-pc cl) + vm:single-value-return-byte-offset) + cl))) + (cond ((and (di::compiled-frame-escaped frame) + (eq (di:code-location-kind code-location) + :single-value-return) + (= (length next) 1) + (di:code-location= (car next) (adjust-pc))) + (debug::next-code-locations (car next))) + (t + next))))) + +(defun set-step-breakpoints (frame) + (let ((cl (di:frame-code-location frame))) + (when (di:debug-block-elsewhere-p (di:code-location-debug-block cl)) + (error "Cannot step in elsewhere code")) + (let* ((debug::*bad-code-location-types* + (remove :call-site debug::*bad-code-location-types*)) + (next (next-code-locations frame cl))) + (cond (next + (let ((steppoints '())) + (flet ((hook (bp-frame bp) + (signal-breakpoint bp bp-frame) + (mapc #'di:delete-breakpoint steppoints))) + (dolist (code-location next) + (let ((bp (di:make-breakpoint #'hook code-location + :kind :code-location))) + (di:activate-breakpoint bp) + (push bp steppoints)))))) + (t + (break-on-return frame)))))) + + +;; XXX the return values at return breakpoints should be passed to the +;; user hooks. debug-int.lisp should be changed to do this cleanly. + +;;; The sigcontext and the PC for a breakpoint invocation are not +;;; passed to user hook functions, but we need them to extract return +;;; values. So we advice di::handle-breakpoint and bind the values to +;;; special variables. +;;; +(defvar *breakpoint-sigcontext*) +(defvar *breakpoint-pc*) + +(defun sigcontext-object (sc index) + "Extract the lisp object in sigcontext SC at offset INDEX." + (kernel:make-lisp-obj (vm:ucontext-register sc index))) + +(defun known-return-point-values (sigcontext sc-offsets) + (let ((fp (system:int-sap (vm:ucontext-register sigcontext + vm::cfp-offset)))) + (system:without-gcing + (loop for sc-offset across sc-offsets + collect (di::sub-access-debug-var-slot fp sc-offset sigcontext))))) + +;;; SCL returns the first few values in registers and the rest on +;;; the stack. In the multiple value case, the number of values is +;;; stored in a dedicated register. The values of the registers can be +;;; accessed in the sigcontext for the breakpoint. There are 3 kinds +;;; of return conventions: :single-value-return, :unknown-return, and +;;; :known-return. +;;; +;;; The :single-value-return convention returns the value in a +;;; register without setting the nargs registers. +;;; +;;; The :unknown-return variant is used for multiple values. A +;;; :unknown-return point consists actually of 2 breakpoints: one for +;;; the single value case and one for the general case. The single +;;; value breakpoint comes vm:single-value-return-byte-offset after +;;; the multiple value breakpoint. +;;; +;;; The :known-return convention is used by local functions. +;;; :known-return is currently not supported because we don't know +;;; where the values are passed. +;;; +(defun breakpoint-values (breakpoint) + "Return the list of return values for a return point." + (flet ((1st (sc) (sigcontext-object sc (car vm::register-arg-offsets)))) + (let ((sc (locally (declare (optimize (ext:inhibit-warnings 3))) + (alien:sap-alien *breakpoint-sigcontext* (* unix:ucontext)))) + (cl (di:breakpoint-what breakpoint))) + (ecase (di:code-location-kind cl) + (:single-value-return + (list (1st sc))) + (:known-return + (let ((info (di:breakpoint-info breakpoint))) + (if (vectorp info) + (known-return-point-values sc info) + (progn + ;;(break) + (list "<<known-return convention not supported>>" info))))) + (:unknown-return + (let ((mv-return-pc (di::compiled-code-location-pc cl))) + (if (= mv-return-pc *breakpoint-pc*) + (mv-function-end-breakpoint-values sc) + (list (1st sc))))))))) + +(defun mv-function-end-breakpoint-values (sigcontext) + (let ((sym (find-symbol + (symbol-name '#:function-end-breakpoint-values/standard) + :debug-internals))) + (cond (sym (funcall sym sigcontext)) + (t (di::get-function-end-breakpoint-values sigcontext))))) + +(defun debug-function-returns (debug-fun) + "Return the return style of DEBUG-FUN." + (let* ((cdfun (di::compiled-debug-function-compiler-debug-fun debug-fun))) + (c::compiled-debug-function-returns cdfun))) + +(define-condition breakpoint (simple-condition) + ((message :initarg :message :reader breakpoint.message) + (values :initarg :values :reader breakpoint.values)) + (:report (lambda (c stream) (princ (breakpoint.message c) stream)))) + +#+nil +(defimplementation condition-extras ((c breakpoint)) + ;; simply pop up the source buffer + `((:short-frame-source 0))) + +(defun signal-breakpoint (breakpoint frame) + "Signal a breakpoint condition for BREAKPOINT in FRAME. +Try to create a informative message." + (flet ((brk (values fstring &rest args) + (let ((msg (apply #'format nil fstring args)) + (debug:*stack-top-hint* frame)) + (break 'breakpoint :message msg :values values)))) + (with-struct (di::breakpoint- kind what) breakpoint + (case kind + (:code-location + (case (di:code-location-kind what) + ((:single-value-return :known-return :unknown-return) + (let ((values (breakpoint-values breakpoint))) + (brk values "Return value: ~{~S ~}" values))) + (t + #+(or) + (when (eq (di:code-location-kind what) :call-site) + (call-site-function breakpoint frame)) + (brk nil "Breakpoint: ~S ~S" + (di:code-location-kind what) + (di::compiled-code-location-pc what))))) + (:function-start + (brk nil "Function start breakpoint")) + (t (brk nil "Breakpoint: ~A in ~A" breakpoint frame)))))) + +#+nil +(defimplementation sldb-break-at-start (fname) + (let ((debug-fun (di:function-debug-function (coerce fname 'function)))) + (cond ((not debug-fun) + `(:error ,(format nil "~S has no debug-function" fname))) + (t + (flet ((hook (frame bp &optional args cookie) + (declare (ignore args cookie)) + (signal-breakpoint bp frame))) + (let ((bp (di:make-breakpoint #'hook debug-fun + :kind :function-start))) + (di:activate-breakpoint bp) + `(:ok ,(format nil "Set breakpoint in ~S" fname)))))))) + +(defun frame-cfp (frame) + "Return the Control-Stack-Frame-Pointer for FRAME." + (etypecase frame + (di::compiled-frame (di::frame-pointer frame)) + ((or di::interpreted-frame null) -1))) + +(defun frame-ip (frame) + "Return the (absolute) instruction pointer and the relative pc of FRAME." + (if (not frame) + -1 + (let ((debug-fun (di::frame-debug-function frame))) + (etypecase debug-fun + (di::compiled-debug-function + (let* ((code-loc (di:frame-code-location frame)) + (component (di::compiled-debug-function-component debug-fun)) + (pc (di::compiled-code-location-pc code-loc)) + (ip (sys:without-gcing + (sys:sap-int + (sys:sap+ (kernel:code-instructions component) pc))))) + (values ip pc))) + ((or di::bogus-debug-function di::interpreted-debug-function) + -1))))) + +(defun frame-registers (frame) + "Return the lisp registers CSP, CFP, IP, OCFP, LRA for FRAME-NUMBER." + (let* ((cfp (frame-cfp frame)) + (csp (frame-cfp (di::frame-up frame))) + (ip (frame-ip frame)) + (ocfp (frame-cfp (di::frame-down frame))) + (lra (frame-ip (di::frame-down frame)))) + (values csp cfp ip ocfp lra))) + +(defun print-frame-registers (frame-number) + (let ((frame (di::frame-real-frame (nth-frame frame-number)))) + (flet ((fixnum (p) (etypecase p + (integer p) + (sys:system-area-pointer (sys:sap-int p))))) + (apply #'format t "~ +CSP = ~X +CFP = ~X +IP = ~X +OCFP = ~X +LRA = ~X~%" (mapcar #'fixnum + (multiple-value-list (frame-registers frame))))))) + + +(defimplementation disassemble-frame (frame-number) + "Return a string with the disassembly of frames code." + (print-frame-registers frame-number) + (terpri) + (let* ((frame (di::frame-real-frame (nth-frame frame-number))) + (debug-fun (di::frame-debug-function frame))) + (etypecase debug-fun + (di::compiled-debug-function + (let* ((component (di::compiled-debug-function-component debug-fun)) + (fun (di:debug-function-function debug-fun))) + (if fun + (disassemble fun) + (disassem:disassemble-code-component component)))) + (di::bogus-debug-function + (format t "~%[Disassembling bogus frames not implemented]"))))) + + +;;;; Inspecting + +(defconstant +lowtag-symbols+ + '(vm:even-fixnum-type + vm:instance-pointer-type + vm:other-immediate-0-type + vm:list-pointer-type + vm:odd-fixnum-type + vm:function-pointer-type + vm:other-immediate-1-type + vm:other-pointer-type) + "Names of the constants that specify type tags. +The `symbol-value' of each element is a type tag.") + +(defconstant +header-type-symbols+ + (labels ((suffixp (suffix string) + (and (>= (length string) (length suffix)) + (string= string suffix :start1 (- (length string) + (length suffix))))) + (header-type-symbol-p (x) + (and (suffixp (symbol-name '#:-type) (symbol-name x)) + (not (member x +lowtag-symbols+)) + (boundp x) + (typep (symbol-value x) 'fixnum)))) + (remove-if-not #'header-type-symbol-p + (append (apropos-list (symbol-name '#:-type) :vm) + (apropos-list (symbol-name '#:-type) :bignum)))) + "A list of names of the type codes in boxed objects.") + +(defimplementation describe-primitive-type (object) + (with-output-to-string (*standard-output*) + (let* ((lowtag (kernel:get-lowtag object)) + (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value))) + (format t "lowtag: ~A" lowtag-symbol) + (when (member lowtag (list vm:other-pointer-type + vm:function-pointer-type + vm:other-immediate-0-type + vm:other-immediate-1-type + )) + (let* ((type (kernel:get-type object)) + (type-symbol (find type +header-type-symbols+ + :key #'symbol-value))) + (format t ", type: ~A" type-symbol)))))) + +(defmethod emacs-inspect ((o t)) + (cond ((di::indirect-value-cell-p o) + `("Value: " (:value ,(c:value-cell-ref o)))) + ((alien::alien-value-p o) + (inspect-alien-value o)) + (t + (scl-inspect o)))) + +(defun scl-inspect (o) + (destructuring-bind (text labeledp . parts) + (inspect::describe-parts o) + (list* (format nil "~A~%" text) + (if labeledp + (loop for (label . value) in parts + append (label-value-line label value)) + (loop for value in parts for i from 0 + append (label-value-line i value)))))) + +(defmethod emacs-inspect ((o function)) + (let ((header (kernel:get-type o))) + (cond ((= header vm:function-header-type) + (list* (format nil "~A is a function.~%" o) + (append (label-value-line* + ("Self" (kernel:%function-self o)) + ("Next" (kernel:%function-next o)) + ("Name" (kernel:%function-name o)) + ("Arglist" (kernel:%function-arglist o)) + ("Type" (kernel:%function-type o)) + ("Code" (kernel:function-code-header o))) + (list + (with-output-to-string (s) + (disassem:disassemble-function o :stream s)))))) + ((= header vm:closure-header-type) + (list* (format nil "~A is a closure.~%" o) + (append + (label-value-line "Function" (kernel:%closure-function o)) + `("Environment:" (:newline)) + (loop for i from 0 below (- (kernel:get-closure-length o) + (1- vm:closure-info-offset)) + append (label-value-line + i (kernel:%closure-index-ref o i)))))) + ((eval::interpreted-function-p o) + (scl-inspect o)) + (t + (call-next-method))))) + + +(defmethod emacs-inspect ((o kernel:code-component)) + (append + (label-value-line* + ("code-size" (kernel:%code-code-size o)) + ("entry-points" (kernel:%code-entry-points o)) + ("debug-info" (kernel:%code-debug-info o)) + ("trace-table-offset" (kernel:code-header-ref + o vm:code-trace-table-offset-slot))) + `("Constants:" (:newline)) + (loop for i from vm:code-constants-offset + below (kernel:get-header-data o) + append (label-value-line i (kernel:code-header-ref o i))) + `("Code:" (:newline) + , (with-output-to-string (s) + (cond ((kernel:%code-debug-info o) + (disassem:disassemble-code-component o :stream s)) + (t + (disassem:disassemble-memory + (disassem::align + (+ (logandc2 (kernel:get-lisp-obj-address o) + vm:lowtag-mask) + (* vm:code-constants-offset vm:word-bytes)) + (ash 1 vm:lowtag-bits)) + (ash (kernel:%code-code-size o) vm:word-shift) + :stream s))))))) + +(defmethod emacs-inspect ((o kernel:fdefn)) + (label-value-line* + ("name" (kernel:fdefn-name o)) + ("function" (kernel:fdefn-function o)) + ("raw-addr" (sys:sap-ref-32 + (sys:int-sap (kernel:get-lisp-obj-address o)) + (* vm:fdefn-raw-addr-slot vm:word-bytes))))) + +(defmethod emacs-inspect ((o array)) + (cond ((kernel:array-header-p o) + (list* (format nil "~A is an array.~%" o) + (label-value-line* + (:header (describe-primitive-type o)) + (:rank (array-rank o)) + (:fill-pointer (kernel:%array-fill-pointer o)) + (:fill-pointer-p (kernel:%array-fill-pointer-p o)) + (:elements (kernel:%array-available-elements o)) + (:data (kernel:%array-data-vector o)) + (:displacement (kernel:%array-displacement o)) + (:displaced-p (kernel:%array-displaced-p o)) + (:dimensions (array-dimensions o))))) + (t + (list* (format nil "~A is an simple-array.~%" o) + (label-value-line* + (:header (describe-primitive-type o)) + (:length (length o))))))) + +(defmethod emacs-inspect ((o simple-vector)) + (list* (format nil "~A is a vector.~%" o) + (append + (label-value-line* + (:header (describe-primitive-type o)) + (:length (c::vector-length o))) + (unless (eq (array-element-type o) 'nil) + (loop for i below (length o) + append (label-value-line i (aref o i))))))) + +(defun inspect-alien-record (alien) + (with-struct (alien::alien-value- sap type) alien + (with-struct (alien::alien-record-type- kind name fields) type + (append + (label-value-line* + (:sap sap) + (:kind kind) + (:name name)) + (loop for field in fields + append (let ((slot (alien::alien-record-field-name field))) + (label-value-line slot (alien:slot alien slot)))))))) + +(defun inspect-alien-pointer (alien) + (with-struct (alien::alien-value- sap type) alien + (label-value-line* + (:sap sap) + (:type type) + (:to (alien::deref alien))))) + +(defun inspect-alien-value (alien) + (typecase (alien::alien-value-type alien) + (alien::alien-record-type (inspect-alien-record alien)) + (alien::alien-pointer-type (inspect-alien-pointer alien)) + (t (scl-inspect alien)))) + +;;;; Profiling +(defimplementation profile (fname) + (eval `(profile:profile ,fname))) + +(defimplementation unprofile (fname) + (eval `(profile:unprofile ,fname))) + +(defimplementation unprofile-all () + (eval `(profile:unprofile)) + "All functions unprofiled.") + +(defimplementation profile-report () + (eval `(profile:report-time))) + +(defimplementation profile-reset () + (eval `(profile:reset-time)) + "Reset profiling counters.") + +(defimplementation profiled-functions () + profile:*timed-functions*) + +(defimplementation profile-package (package callers methods) + (profile:profile-all :package package + :callers-p callers + #+nil :methods #+nil methods)) + + +;;;; Multiprocessing + +(defimplementation spawn (fn &key name) + (thread:thread-create fn :name (or name "Anonymous"))) + +(defvar *thread-id-counter* 0) +(defvar *thread-id-counter-lock* (thread:make-lock "Thread ID counter")) + +(defimplementation thread-id (thread) + (thread:with-lock-held (*thread-id-counter-lock*) + (or (getf (thread:thread-plist thread) 'id) + (setf (getf (thread:thread-plist thread) 'id) + (incf *thread-id-counter*))))) + +(defimplementation find-thread (id) + (block find-thread + (thread:map-over-threads + #'(lambda (thread) + (when (eql (getf (thread:thread-plist thread) 'id) id) + (return-from find-thread thread)))))) + +(defimplementation thread-name (thread) + (princ-to-string (thread:thread-name thread))) + +(defimplementation thread-status (thread) + (let ((dynamic-values (thread::thread-dynamic-values thread))) + (if (zerop dynamic-values) "Exited" "Running"))) + +(defimplementation make-lock (&key name) + (thread:make-lock name)) + +(defimplementation call-with-lock-held (lock function) + (declare (type function function)) + (thread:with-lock-held (lock) (funcall function))) + +(defimplementation current-thread () + thread:*thread*) + +(defimplementation all-threads () + (let ((all-threads nil)) + (thread:map-over-threads #'(lambda (thread) (push thread all-threads))) + all-threads)) + +(defimplementation interrupt-thread (thread fn) + (thread:thread-interrupt thread #'(lambda () + (sys:with-interrupts + (funcall fn))))) + +(defimplementation kill-thread (thread) + (thread:destroy-thread thread)) + +(defimplementation thread-alive-p (thread) + (not (zerop (thread::thread-dynamic-values thread)))) + +(defvar *mailbox-lock* (thread:make-lock "Mailbox lock" :interruptible nil)) + +(defstruct (mailbox) + (lock (thread:make-lock "Thread mailbox" :type :error-check + :interruptible nil) + :type thread:error-check-lock) + (queue '() :type list)) + +(defun mailbox (thread) + "Return 'thread's mailbox." + (sys:without-interrupts + (thread:with-lock-held (*mailbox-lock*) + (or (getf (thread:thread-plist thread) 'mailbox) + (setf (getf (thread:thread-plist thread) 'mailbox) + (make-mailbox)))))) + +(defimplementation send (thread message) + (let* ((mbox (mailbox thread)) + (lock (mailbox-lock mbox))) + (sys:without-interrupts + (thread:with-lock-held (lock "Mailbox Send") + (setf (mailbox-queue mbox) (nconc (mailbox-queue mbox) + (list message))))) + (mp:process-wakeup thread))) + +#+nil +(defimplementation receive () + (receive-if (constantly t))) + +(defimplementation receive-if (test &optional timeout) + (let ((mbox (mailbox thread:*thread*))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (sys:without-interrupts + (mp:with-lock-held ((mailbox-lock mbox)) + (let* ((q (mailbox-queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox-queue mbox) + (nconc (ldiff q tail) (cdr tail))) + (return (car tail)))))) + (when (eq timeout t) (return (values nil t))) + (mp:process-wait-with-timeout + "Mailbox read wait" 0.5 (lambda () (some test (mailbox-queue mbox))))))) + + + +(defimplementation emacs-connected ()) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;Trace implementations +;; In SCL, we have: +;; (trace <name>) +;; (trace (method <name> <qualifier>? (<specializer>+))) +;; (trace :methods t '<name>) ;;to trace all methods of the gf <name> +;; <name> can be a normal name or a (setf name) + +(defun tracedp (spec) + (member spec (eval '(trace)) :test #'equal)) + +(defun toggle-trace-aux (spec &rest options) + (cond ((tracedp spec) + (eval `(untrace ,spec)) + (format nil "~S is now untraced." spec)) + (t + (eval `(trace ,spec ,@options)) + (format nil "~S is now traced." spec)))) + +(defimplementation toggle-trace (spec) + (ecase (car spec) + ((setf) + (toggle-trace-aux spec)) + ((:defgeneric) + (let ((name (second spec))) + (toggle-trace-aux name :methods name))) + ((:defmethod) + nil) + ((:call) + (destructuring-bind (caller callee) (cdr spec) + (toggle-trace-aux (process-fspec callee) + :wherein (list (process-fspec caller))))))) + +(defun process-fspec (fspec) + (cond ((consp fspec) + (ecase (first fspec) + ((:defun :defgeneric) (second fspec)) + ((:defmethod) + `(method ,(second fspec) ,@(third fspec) ,(fourth fspec))) + ;; this isn't actually supported + ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec))) + ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec))))) + (t + fspec))) + +;;; Weak datastructures + +;;; Not implemented in SCL. +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak-p t args)) diff --git a/vim/bundle/slimv/slime/swank/source-file-cache.lisp b/vim/bundle/slimv/slime/swank/source-file-cache.lisp new file mode 100644 index 0000000..ac48acf --- /dev/null +++ b/vim/bundle/slimv/slime/swank/source-file-cache.lisp @@ -0,0 +1,136 @@ +;;;; Source-file cache +;;; +;;; To robustly find source locations in CMUCL and SBCL it's useful to +;;; have the exact source code that the loaded code was compiled from. +;;; In this source we can accurately find the right location, and from +;;; that location we can extract a "snippet" of code to show what the +;;; definition looks like. Emacs can use this snippet in a best-match +;;; search to locate the right definition, which works well even if +;;; the buffer has been modified. +;;; +;;; The idea is that if a definition previously started with +;;; `(define-foo bar' then it probably still does. +;;; +;;; Whenever we see that the file on disk has the same +;;; `file-write-date' as a location we're looking for we cache the +;;; whole file inside Lisp. That way we will still have the matching +;;; version even if the file is later modified on disk. If the file is +;;; later recompiled and reloaded then we replace our cache entry. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. + +(defpackage swank/source-file-cache + (:use cl) + (:import-from swank/backend + defimplementation buffer-first-change + guess-external-format + find-external-format) + (:export + get-source-code + source-cache-get ;FIXME: isn't it odd that both are exported? + + *source-snippet-size* + read-snippet + read-snippet-from-string + )) + +(in-package swank/source-file-cache) + +(defvar *cache-sourcecode* t + "When true complete source files are cached. +The cache is used to keep known good copies of the source text which +correspond to the loaded code. Finding definitions is much more +reliable when the exact source is available, so we cache it in case it +gets edited on disk later.") + +(defvar *source-file-cache* (make-hash-table :test 'equal) + "Cache of source file contents. +Maps from truename to source-cache-entry structure.") + +(defstruct (source-cache-entry + (:conc-name source-cache-entry.) + (:constructor make-source-cache-entry (text date))) + text date) + +(defimplementation buffer-first-change (filename) + "Load a file into the cache when the user modifies its buffer. +This is a win if the user then saves the file and tries to M-. into it." + (unless (source-cached-p filename) + (ignore-errors + (source-cache-get filename (file-write-date filename)))) + nil) + +(defun get-source-code (filename code-date) + "Return the source code for FILENAME as written on DATE in a string. +If the exact version cannot be found then return the current one from disk." + (or (source-cache-get filename code-date) + (read-file filename))) + +(defun source-cache-get (filename date) + "Return the source code for FILENAME as written on DATE in a string. +Return NIL if the right version cannot be found." + (when *cache-sourcecode* + (let ((entry (gethash filename *source-file-cache*))) + (cond ((and entry (equal date (source-cache-entry.date entry))) + ;; Cache hit. + (source-cache-entry.text entry)) + ((or (null entry) + (not (equal date (source-cache-entry.date entry)))) + ;; Cache miss. + (if (equal (file-write-date filename) date) + ;; File on disk has the correct version. + (let ((source (read-file filename))) + (setf (gethash filename *source-file-cache*) + (make-source-cache-entry source date)) + source) + nil)))))) + +(defun source-cached-p (filename) + "Is any version of FILENAME in the source cache?" + (if (gethash filename *source-file-cache*) t)) + +(defun read-file (filename) + "Return the entire contents of FILENAME as a string." + (with-open-file (s filename :direction :input + :external-format (or (guess-external-format filename) + (find-external-format "latin-1") + :default)) + (let* ((string (make-string (file-length s))) + (length (read-sequence string s))) + (subseq string 0 length)))) + +;;;; Snippets + +(defvar *source-snippet-size* 256 + "Maximum number of characters in a snippet of source code. +Snippets at the beginning of definitions are used to tell Emacs what +the definitions looks like, so that it can accurately find them by +text search.") + +(defun read-snippet (stream &optional position) + "Read a string of upto *SOURCE-SNIPPET-SIZE* characters from STREAM. +If POSITION is given, set the STREAM's file position first." + (when position + (file-position stream position)) + #+sbcl (skip-comments-and-whitespace stream) + (read-upto-n-chars stream *source-snippet-size*)) + +(defun read-snippet-from-string (string &optional position) + (with-input-from-string (s string) + (read-snippet s position))) + +(defun skip-comments-and-whitespace (stream) + (case (peek-char nil stream) + ((#\Space #\Tab #\Newline #\Linefeed #\Page) + (read-char stream) + (skip-comments-and-whitespace stream)) + (#\; + (read-line stream) + (skip-comments-and-whitespace stream)))) + +(defun read-upto-n-chars (stream n) + "Return a string of upto N chars from STREAM." + (let* ((string (make-string n)) + (chars (read-sequence string stream))) + (subseq string 0 chars))) diff --git a/vim/bundle/slimv/slime/swank/source-path-parser.lisp b/vim/bundle/slimv/slime/swank/source-path-parser.lisp new file mode 100644 index 0000000..bb9c35c --- /dev/null +++ b/vim/bundle/slimv/slime/swank/source-path-parser.lisp @@ -0,0 +1,239 @@ +;;;; Source-paths + +;;; CMUCL/SBCL use a data structure called "source-path" to locate +;;; subforms. The compiler assigns a source-path to each form in a +;;; compilation unit. Compiler notes usually contain the source-path +;;; of the error location. +;;; +;;; Compiled code objects don't contain source paths, only the +;;; "toplevel-form-number" and the (sub-) "form-number". To get from +;;; the form-number to the source-path we need the entire toplevel-form +;;; (i.e. we have to read the source code). CMUCL has already some +;;; utilities to do this translation, but we use some extended +;;; versions, because we need more exact position info. Apparently +;;; Hemlock is happy with the position of the toplevel-form; we also +;;; need the position of subforms. +;;; +;;; We use a special readtable to get the positions of the subforms. +;;; The readtable stores the start and end position for each subform in +;;; hashtable for later retrieval. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. + +;;; Taken from swank-cmucl.lisp, by Helmut Eller + +(defpackage swank/source-path-parser + (:use cl) + (:export + read-source-form + source-path-string-position + source-path-file-position + source-path-source-position + + sexp-in-bounds-p + sexp-ref) + (:shadow ignore-errors)) + +(in-package swank/source-path-parser) + +;; Some test to ensure the required conformance +(let ((rt (copy-readtable nil))) + (assert (or (not (get-macro-character #\space rt)) + (nth-value 1 (get-macro-character #\space rt)))) + (assert (not (get-macro-character #\\ rt)))) + +(eval-when (:compile-toplevel) + (defmacro ignore-errors (&rest forms) + ;;`(progn . ,forms) ; for debugging + `(cl:ignore-errors . ,forms))) + +(defun make-sharpdot-reader (orig-sharpdot-reader) + (lambda (s c n) + ;; We want things like M-. to work regardless of any #.-fu in + ;; the source file that is to be visited. (For instance, when a + ;; file contains #. forms referencing constants that do not + ;; currently exist in the image.) + (ignore-errors (funcall orig-sharpdot-reader s c n)))) + +(defun make-source-recorder (fn source-map) + "Return a macro character function that does the same as FN, but +additionally stores the result together with the stream positions +before and after of calling FN in the hashtable SOURCE-MAP." + (lambda (stream char) + (let ((start (1- (file-position stream))) + (values (multiple-value-list (funcall fn stream char))) + (end (file-position stream))) + #+(or) + (format t "[~D \"~{~A~^, ~}\" ~D ~D ~S]~%" + start values end (char-code char) char) + (when values + (destructuring-bind (&optional existing-start &rest existing-end) + (car (gethash (car values) source-map)) + ;; Some macros may return what a sub-call to another macro + ;; produced, e.g. "#+(and) (a)" may end up saving (a) twice, + ;; once from #\# and once from #\(. If the saved form + ;; is a subform, don't save it again. + (unless (and existing-start existing-end + (<= start existing-start end) + (<= start existing-end end)) + (push (cons start end) (gethash (car values) source-map))))) + (values-list values)))) + +(defun make-source-recording-readtable (readtable source-map) + (declare (type readtable readtable) (type hash-table source-map)) + "Return a source position recording copy of READTABLE. +The source locations are stored in SOURCE-MAP." + (flet ((install-special-sharpdot-reader (rt) + (let ((fun (ignore-errors + (get-dispatch-macro-character #\# #\. rt)))) + (when fun + (let ((wrapper (make-sharpdot-reader fun))) + (set-dispatch-macro-character #\# #\. wrapper rt))))) + (install-wrappers (rt) + (dotimes (code 128) + (let ((char (code-char code))) + (multiple-value-bind (fun nt) (get-macro-character char rt) + (when fun + (let ((wrapper (make-source-recorder fun source-map))) + (set-macro-character char wrapper nt rt)))))))) + (let ((rt (copy-readtable readtable))) + (install-special-sharpdot-reader rt) + (install-wrappers rt) + rt))) + +;; FIXME: try to do this with *READ-SUPPRESS* = t to avoid interning. +;; Should be possible as we only need the right "list structure" and +;; not the right atoms. +(defun read-and-record-source-map (stream) + "Read the next object from STREAM. +Return the object together with a hashtable that maps +subexpressions of the object to stream positions." + (let* ((source-map (make-hash-table :test #'eq)) + (*readtable* (make-source-recording-readtable *readtable* source-map)) + (*read-suppress* nil) + (start (file-position stream)) + (form (ignore-errors (read stream))) + (end (file-position stream))) + ;; ensure that at least FORM is in the source-map + (unless (gethash form source-map) + (push (cons start end) (gethash form source-map))) + (values form source-map))) + +(defun starts-with-p (string prefix) + (declare (type string string prefix)) + (not (mismatch string prefix + :end1 (min (length string) (length prefix)) + :test #'char-equal))) + +(defun extract-package (line) + (declare (type string line)) + (let ((name (cadr (read-from-string line)))) + (find-package name))) + +#+(or) +(progn + (assert (extract-package "(in-package cl)")) + (assert (extract-package "(cl:in-package cl)")) + (assert (extract-package "(in-package \"CL\")")) + (assert (extract-package "(in-package #:cl)"))) + +;; FIXME: do something cleaner than this. +(defun readtable-for-package (package) + ;; KLUDGE: due to the load order we can't reference the swank + ;; package. + (funcall (read-from-string "swank::guess-buffer-readtable") + (string-upcase (package-name package)))) + +;; Search STREAM for a "(in-package ...)" form. Use that to derive +;; the values for *PACKAGE* and *READTABLE*. +;; +;; IDEA: move GUESS-READER-STATE to swank.lisp so that all backends +;; use the same heuristic and to avoid the need to access +;; swank::guess-buffer-readtable from here. +(defun guess-reader-state (stream) + (let* ((point (file-position stream)) + (pkg *package*)) + (file-position stream 0) + (loop for line = (read-line stream nil nil) do + (when (not line) (return)) + (when (or (starts-with-p line "(in-package ") + (starts-with-p line "(cl:in-package ")) + (let ((p (extract-package line))) + (when p (setf pkg p))) + (return))) + (file-position stream point) + (values (readtable-for-package pkg) pkg))) + +(defun skip-whitespace (stream) + (peek-char t stream nil nil)) + +;; Skip over N toplevel forms. +(defun skip-toplevel-forms (n stream) + (let ((*read-suppress* t)) + (dotimes (i n) + (read stream)) + (skip-whitespace stream))) + +(defun read-source-form (n stream) + "Read the Nth toplevel form number with source location recording. +Return the form and the source-map." + (multiple-value-bind (*readtable* *package*) (guess-reader-state stream) + (skip-toplevel-forms n stream) + (read-and-record-source-map stream))) + +(defun source-path-stream-position (path stream) + "Search the source-path PATH in STREAM and return its position." + (check-source-path path) + (destructuring-bind (tlf-number . path) path + (multiple-value-bind (form source-map) (read-source-form tlf-number stream) + (source-path-source-position (cons 0 path) form source-map)))) + +(defun check-source-path (path) + (unless (and (consp path) + (every #'integerp path)) + (error "The source-path ~S is not valid." path))) + +(defun source-path-string-position (path string) + (with-input-from-string (s string) + (source-path-stream-position path s))) + +(defun source-path-file-position (path filename) + ;; We go this long way round, and don't directly operate on the file + ;; stream because FILE-POSITION (used above) is not totally savy even + ;; on file character streams; on SBCL, FILE-POSITION returns the binary + ;; offset, and not the character offset---screwing up on Unicode. + (let ((toplevel-number (first path)) + (buffer)) + (with-open-file (file filename) + (skip-toplevel-forms (1+ toplevel-number) file) + (let ((endpos (file-position file))) + (setq buffer (make-array (list endpos) :element-type 'character + :initial-element #\Space)) + (assert (file-position file 0)) + (read-sequence buffer file :end endpos))) + (source-path-string-position path buffer))) + +(defgeneric sexp-in-bounds-p (sexp i) + (:method ((list list) i) + (< i (loop for e on list + count t))) + (:method ((sexp t) i) nil)) + +(defgeneric sexp-ref (sexp i) + (:method ((s list) i) (elt s i))) + +(defun source-path-source-position (path form source-map) + "Return the start position of PATH from FORM and SOURCE-MAP. All +subforms along the path are considered and the start and end position +of the deepest (i.e. smallest) possible form is returned." + ;; compute all subforms along path + (let ((forms (loop for i in path + for f = form then (if (sexp-in-bounds-p f i) + (sexp-ref f i)) + collect f))) + ;; select the first subform present in source-map + (loop for form in (nreverse forms) + for ((start . end) . rest) = (gethash form source-map) + when (and start end (not rest)) + return (return (values start end))))) diff --git a/vim/bundle/slimv/slime/xref.lisp b/vim/bundle/slimv/slime/xref.lisp new file mode 100644 index 0000000..e09a150 --- /dev/null +++ b/vim/bundle/slimv/slime/xref.lisp @@ -0,0 +1,2906 @@ +;;; -*- Mode: LISP; Package: XREF; Syntax: Common-lisp; -*- +;;; Mon Jan 21 16:21:20 1991 by Mark Kantrowitz <mkant@GLINDA.OZ.CS.CMU.EDU> +;;; xref.lisp + +;;; **************************************************************** +;;; List Callers: A Static Analysis Cross Referencing Tool for Lisp +;;; **************************************************************** +;;; +;;; The List Callers system is a portable Common Lisp cross referencing +;;; utility. It grovels over a set of files and compiles a database of the +;;; locations of all references for each symbol used in the files. +;;; List Callers is similar to the Symbolics Who-Calls and the +;;; Xerox Masterscope facilities. +;;; +;;; When you change a function or variable definition, it can be useful +;;; to know its callers, in order to update each of them to the new +;;; definition. Similarly, having a graphic display of the structure +;;; (e.g., call graph) of a program can help make undocumented code more +;;; understandable. This static code analyzer facilitates both capabilities. +;;; The database compiled by xref is suitable for viewing by a graphical +;;; browser. (Note: the reference graph is not necessarily a DAG. Since many +;;; graphical browsers assume a DAG, this will lead to infinite loops. +;;; Some code which is useful in working around this problem is included, +;;; as well as a sample text-indenting outliner and an interface to Bates' +;;; PSGraph Postscript Graphing facility.) +;;; +;;; Written by Mark Kantrowitz, July 1990. +;;; +;;; Address: School of Computer Science +;;; Carnegie Mellon University +;;; Pittsburgh, PA 15213 +;;; +;;; Copyright (c) 1990. All rights reserved. +;;; +;;; See general license below. +;;; + +;;; **************************************************************** +;;; General License Agreement and Lack of Warranty ***************** +;;; **************************************************************** +;;; +;;; This software is distributed in the hope that it will be useful (both +;;; in and of itself and as an example of lisp programming), but WITHOUT +;;; ANY WARRANTY. The author(s) do not accept responsibility to anyone for +;;; the consequences of using it or for whether it serves any particular +;;; purpose or works at all. No warranty is made about the software or its +;;; performance. +;;; +;;; Use and copying of this software and the preparation of derivative +;;; works based on this software are permitted, so long as the following +;;; conditions are met: +;;; o The copyright notice and this entire notice are included intact +;;; and prominently carried on all copies and supporting documentation. +;;; o No fees or compensation are charged for use, copies, or +;;; access to this software. You may charge a nominal +;;; distribution fee for the physical act of transferring a +;;; copy, but you may not charge for the program itself. +;;; o If you modify this software, you must cause the modified +;;; file(s) to carry prominent notices (a Change Log) +;;; describing the changes, who made the changes, and the date +;;; of those changes. +;;; o Any work distributed or published that in whole or in part +;;; contains or is a derivative of this software or any part +;;; thereof is subject to the terms of this agreement. The +;;; aggregation of another unrelated program with this software +;;; or its derivative on a volume of storage or distribution +;;; medium does not bring the other program under the scope +;;; of these terms. +;;; o Permission is granted to manufacturers and distributors of +;;; lisp compilers and interpreters to include this software +;;; with their distribution. +;;; +;;; This software is made available AS IS, and is distributed without +;;; warranty of any kind, either expressed or implied. +;;; +;;; In no event will the author(s) or their institutions be liable to you +;;; for damages, including lost profits, lost monies, or other special, +;;; incidental or consequential damages arising out of or in connection +;;; with the use or inability to use (including but not limited to loss of +;;; data or data being rendered inaccurate or losses sustained by third +;;; parties or a failure of the program to operate as documented) the +;;; program, even if you have been advised of the possibility of such +;;; damanges, or for any claim by any other party, whether in an action of +;;; contract, negligence, or other tortious action. +;;; +;;; The current version of this software and a variety of related utilities +;;; may be obtained by anonymous ftp from ftp.cs.cmu.edu in the directory +;;; user/ai/lang/lisp/code/tools/xref/ +;;; +;;; Please send bug reports, comments, questions and suggestions to +;;; mkant@cs.cmu.edu. We would also appreciate receiving any changes +;;; or improvements you may make. +;;; +;;; If you wish to be added to the Lisp-Utilities@cs.cmu.edu mailing list, +;;; send email to Lisp-Utilities-Request@cs.cmu.edu with your name, email +;;; address, and affiliation. This mailing list is primarily for +;;; notification about major updates, bug fixes, and additions to the lisp +;;; utilities collection. The mailing list is intended to have low traffic. +;;; + +;;; ******************************** +;;; Change Log ********************* +;;; ******************************** +;;; +;;; 27-FEB-91 mk Added insert arg to psgraph-xref to allow the postscript +;;; graphs to be inserted in Scribe documents. +;;; 21-FEB-91 mk Added warning if not compiled. +;;; 07-FEB-91 mk Fixed bug in record-callers with regard to forms at +;;; toplevel. +;;; 21-JAN-91 mk Added file xref-test.lisp to test xref. +;;; 16-JAN-91 mk Added definition WHO-CALLS to parallel the Symbolics syntax. +;;; 16-JAN-91 mk Added macroexpansion capability to record-callers. Also +;;; added parameter *handle-macro-forms*, defaulting to T. +;;; 16-JAN-91 mk Modified print-caller-tree and related functions +;;; to allow the user to specify root nodes. If the user +;;; doesn't specify them, it will default to all root +;;; nodes, as before. +;;; 16-JAN-91 mk Added parameter *default-graphing-mode* to specify +;;; the direction of the graphing. Either :call-graph, +;;; where the children of a node are those functions called +;;; by the node, or :caller-graph where the children of a +;;; node are the callers of the node. :call-graph is the +;;; default. +;;; 16-JAN-91 mk Added parameter *indent-amount* to control the indentation +;;; in print-indented-tree. +;;; 16-JUL-90 mk Functions with argument lists of () were being ignored +;;; because of a (when form) wrapped around the body of +;;; record-callers. Then intent of (when form) was as an extra +;;; safeguard against infinite looping. This wasn't really +;;; necessary, so it has been removed. +;;; 16-JUL-90 mk PSGraph-XREF now has keyword arguments, instead of +;;; optionals. +;;; 16-JUL-90 mk Added PRINT-CLASS-HIERARCHY to use psgraph to graph the +;;; CLOS class hierarchy. This really doesn't belong here, +;;; and should be moved to psgraph.lisp as an example of how +;;; to use psgraph. +;;; 16-JUL-90 mk Fixed several caller patterns. The pattern for member +;;; had an error which caused many references to be missed. +;;; 16-JUL-90 mk Added ability to save/load processed databases. +;;; 5-JUL-91 mk Fixed warning of needing compilation to occur only when the +;;; source is loaded. +;;; 20-SEP-93 mk Added fix from Peter Norvig to allow Xref to xref itself. +;;; The arg to macro-function must be a symbol. +;;; 7-APR-12 heller Break lines at 80 columns. + +;;; ******************************** +;;; To Do ************************** +;;; ******************************** +;;; +;;; Verify that: +;;; o null forms don't cause it to infinite loop. +;;; o nil matches against null argument lists. +;;; o declarations and doc are being ignored. +;;; +;;; Would be nice if in addition to showing callers of a function, it +;;; displayed the context of the calls to the function (e.g., the +;;; immediately surrounding form). This entails storing entries of +;;; the form (symbol context*) in the database and augmenting +;;; record-callers to keep the context around. The only drawbacks is +;;; that it would cons a fair bit. If we do this, we should store +;;; additional information as well in the database, such as the caller +;;; pattern type (e.g., variable vs. function). +;;; +;;; Write a translator from BNF (at least as much of BNF as is used +;;; in CLtL2), to the format used here. +;;; +;;; Should automatically add new patterns for new functions and macros +;;; based on their arglists. Probably requires much more than this +;;; simple code walker, so there isn't much we can do. +;;; +;;; Defmacro is a problem, because it often hides internal function +;;; calls within backquote and quote, which we normally ignore. If +;;; we redefine QUOTE's pattern so that it treats the arg like a FORM, +;;; we'll probably get them (though maybe the syntax will be mangled), +;;; but most likely a lot of spurious things as well. +;;; +;;; Define an operation for Defsystem which will run XREF-FILE on the +;;; files of the system. Or yet simpler, when XREF sees a LOAD form +;;; for which the argument is a string, tries to recursively call +;;; XREF-FILE on the specified file. Then one could just XREF-FILE +;;; the file which loads the system. (This should be a program +;;; parameter.) +;;; +;;; Have special keywords which the user may place in a file to have +;;; XREF-FILE ignore a region. +;;; +;;; Should we distinguish flet and labels from defun? I.e., note that +;;; flet's definitions are locally defined, instead of just lumping +;;; them in with regular definitions. +;;; +;;; Add patterns for series, loop macro. +;;; +;;; Need to integrate the variable reference database with the other +;;; databases, yet maintain separation. So we can distinguish all +;;; the different types of variable and function references, without +;;; multiplying databases. +;;; +;;; Would pay to comment record-callers and record-callers* in more +;;; depth. +;;; +;;; (&OPTIONAL &REST &KEY &AUX &BODY &WHOLE &ALLOW-OTHER-KEYS &ENVIRONMENT) + +;;; ******************************** +;;; Notes ************************** +;;; ******************************** +;;; +;;; XREF has been tested (successfully) in the following lisps: +;;; CMU Common Lisp (M2.9 15-Aug-90, Compiler M1.8 15-Aug-90) +;;; Macintosh Allegro Common Lisp (1.3.2) +;;; ExCL (Franz Allegro CL 3.1.12 [DEC 3100] 3/30/90) +;;; Lucid CL (Version 2.1 6-DEC-87) +;;; +;;; XREF has been tested (unsuccessfully) in the following lisps: +;;; Ibuki Common Lisp (01/01, October 15, 1987) +;;; - if interpreted, runs into stack overflow +;;; - does not compile (tried ibcl on Suns, PMAXes and RTs) +;;; seems to be due to a limitation in the c compiler. +;;; +;;; XREF needs to be tested in the following lisps: +;;; Symbolics Common Lisp (8.0) +;;; Lucid Common Lisp (3.0, 4.0) +;;; KCL (June 3, 1987 or later) +;;; AKCL (1.86, June 30, 1987 or later) +;;; TI (Release 4.1 or later) +;;; Golden Common Lisp (3.1 IBM-PC) +;;; VAXLisp (2.0, 3.1) +;;; HP Common Lisp (same as Lucid?) +;;; Procyon Common Lisp + + +;;; **************************************************************** +;;; Documentation ************************************************** +;;; **************************************************************** +;;; +;;; XREF analyzes a user's program, determining which functions call a +;;; given function, and the location of where variables are bound/assigned +;;; and used. The user may retrieve this information for either a single +;;; symbol, or display the call graph of portions of the program +;;; (including the entire program). This allows the programmer to debug +;;; and document the program's structure. +;;; +;;; XREF is primarily intended for analyzing large programs, where it is +;;; difficult, if not impossible, for the programmer to grasp the structure +;;; of the whole program. Nothing precludes using XREF for smaller programs, +;;; where it can be useful for inspecting the relationships between pieces +;;; of the program and for documenting the program. +;;; +;;; Two aspects of the Lisp programming language greatly simplify the +;;; analysis of Lisp programs: +;;; o Lisp programs are naturally represented as data. +;;; Successive definitions from a file are easily read in +;;; as list structure. +;;; o The basic syntax of Lisp is uniform. A list program +;;; consists of a set of nested forms, where each form is +;;; a list whose car is a tag (e.g., function name) that +;;; specifies the structure of the rest of the form. +;;; Thus Lisp programs, when represented as data, can be considered to be +;;; parse trees. Given a grammar of syntax patterns for the language, XREF +;;; recursively descends the parse tree for a given definition, computing +;;; a set of relations that hold for the definition at each node in the +;;; tree. For example, one kind of relation is that the function defined +;;; by the definition calls the functions in its body. The relations are +;;; stored in a database for later examination by the user. +;;; +;;; While XREF currently only works for programs written in Lisp, it could +;;; be extended to other programming languages by writing a function to +;;; generate parse trees for definitions in that language, and a core +;;; set of patterns for the language's syntax. +;;; +;;; Since XREF normally does a static syntactic analysis of the program, +;;; it does not detect references due to the expansion of a macro definition. +;;; To do this in full generality XREF would have to have knowledge about the +;;; semantics of the program (e.g., macros which call other functions to +;;; do the expansion). This entails either modifying the compiler to +;;; record the relationships (e.g., Symbolics Who-Calls Database) or doing +;;; a walk of loaded code and macroexpanding as needed (PCL code walker). +;;; The former is not portable, while the latter requires that the code +;;; used by macros be loaded and in working order. On the other hand, then +;;; we would need no special knowledge about macros (excluding the 24 special +;;; forms of Lisp). +;;; +;;; Parameters may be set to enable macro expansion in XREF. Then XREF +;;; will expand any macros for which it does not have predefined patterns. +;;; (For example, most Lisps will implement dolist as a macro. Since XREF +;;; has a pattern defined for dolist, it will not call macroexpand-1 on +;;; a form whose car is dolist.) For this to work properly, the code must +;;; be loaded before being processed by XREF, and XREF's parameters should +;;; be set so that it processes forms in their proper packages. +;;; +;;; If macro expansion is disabled, the default rules for handling macro +;;; references may not be sufficient for some user-defined macros, because +;;; macros allow a variety of non-standard syntactic extensions to the +;;; language. In this case, the user may specify additional templates in +;;; a manner similar to that in which the core Lisp grammar was specified. +;;; + + +;;; ******************************** +;;; User Guide ********************* +;;; ******************************** +;;; ----- +;;; The following functions are called to cross reference the source files. +;;; +;;; XREF-FILES (&rest files) [FUNCTION] +;;; Grovels over the lisp code located in source file FILES, using +;;; xref-file. +;;; +;;; XREF-FILE (filename &optional clear-tables verbose) [Function] +;;; Cross references the function and variable calls in FILENAME by +;;; walking over the source code located in the file. Defaults type of +;;; filename to ".lisp". Chomps on the code using record-callers and +;;; record-callers*. If CLEAR-TABLES is T (the default), it clears the +;;; callers database before processing the file. Specify CLEAR-TABLES as +;;; nil to append to the database. If VERBOSE is T (the default), prints +;;; out the name of the file, one progress dot for each form processed, +;;; and the total number of forms. +;;; +;;; ----- +;;; The following functions display information about the uses of the +;;; specified symbol as a function, variable, or constant. +;;; +;;; LIST-CALLERS (symbol) [FUNCTION] +;;; Lists all functions which call SYMBOL as a function (function +;;; invocation). +;;; +;;; LIST-READERS (symbol) [FUNCTION] +;;; Lists all functions which refer to SYMBOL as a variable +;;; (variable reference). +;;; +;;; LIST-SETTERS (symbol) [FUNCTION] +;;; Lists all functions which bind/set SYMBOL as a variable +;;; (variable mutation). +;;; +;;; LIST-USERS (symbol) [FUNCTION] +;;; Lists all functions which use SYMBOL as a variable or function. +;;; +;;; WHO-CALLS (symbol &optional how) [FUNCTION] +;;; Lists callers of symbol. HOW may be :function, :reader, :setter, +;;; or :variable." +;;; +;;; WHAT-FILES-CALL (symbol) [FUNCTION] +;;; Lists names of files that contain uses of SYMBOL +;;; as a function, variable, or constant. +;;; +;;; SOURCE-FILE (symbol) [FUNCTION] +;;; Lists the names of files in which SYMBOL is defined/used. +;;; +;;; LIST-CALLEES (symbol) [FUNCTION] +;;; Lists names of functions and variables called by SYMBOL. +;;; +;;; ----- +;;; The following functions may be useful for viewing the database and +;;; debugging the calling patterns. +;;; +;;; *LAST-FORM* () [VARIABLE] +;;; The last form read from the file. Useful for figuring out what went +;;; wrong when xref-file drops into the debugger. +;;; +;;; *XREF-VERBOSE* t [VARIABLE] +;;; When T, xref-file(s) prints out the names of the files it looks at, +;;; progress dots, and the number of forms read. +;;; +;;; *TYPES-TO-IGNORE* (quote (:lisp :lisp2)) [VARIABLE] +;;; Default set of caller types (as specified in the patterns) to ignore +;;; in the database handling functions. :lisp is CLtL 1st edition, +;;; :lisp2 is additional patterns from CLtL 2nd edition. +;;; +;;; *HANDLE-PACKAGE-FORMS* () [VARIABLE] +;;; When non-NIL, and XREF-FILE sees a package-setting form like +;;; IN-PACKAGE, sets the current package to the specified package by +;;; evaluating the form. When done with the file, xref-file resets the +;;; package to its original value. In some of the displaying functions, +;;; when this variable is non-NIL one may specify that all symbols from a +;;; particular set of packages be ignored. This is only useful if the +;;; files use different packages with conflicting names. +;;; +;;; *HANDLE-FUNCTION-FORMS* t [VARIABLE] +;;; When T, XREF-FILE tries to be smart about forms which occur in +;;; a function position, such as lambdas and arbitrary Lisp forms. +;;; If so, it recursively calls record-callers with pattern 'FORM. +;;; If the form is a lambda, makes the caller a caller of +;;; :unnamed-lambda. +;;; +;;; *HANDLE-MACRO-FORMS* t [VARIABLE] +;;; When T, if the file was loaded before being processed by XREF, and +;;; the car of a form is a macro, it notes that the parent calls the +;;; macro, and then calls macroexpand-1 on the form. +;;; +;;; *DEFAULT-GRAPHING-MODE* :call-graph [VARIABLE] +;;; Specifies whether we graph up or down. If :call-graph, the children +;;; of a node are the functions it calls. If :caller-graph, the +;;; children of a node are the functions that call it. +;;; +;;; *INDENT-AMOUNT* 3 [VARIABLE] +;;; Number of spaces to indent successive levels in PRINT-INDENTED-TREE. +;;; +;;; DISPLAY-DATABASE (&optional database types-to-ignore) [FUNCTION] +;;; Prints out the name of each symbol and all its callers. Specify +;;; database :callers (the default) to get function call references, +;;; :file to the get files in which the symbol is called, :readers to get +;;; variable references, and :setters to get variable binding and +;;; assignments. Ignores functions of types listed in types-to-ignore. +;;; +;;; PRINT-CALLER-TREES (&key (mode *default-graphing-mode*) [FUNCTION] +;;; (types-to-ignore *types-to-ignore*) +;;; compact root-nodes) +;;; Prints the calling trees (which may actually be a full graph and not +;;; necessarily a DAG) as indented text trees using +;;; PRINT-INDENTED-TREE. MODE is :call-graph for trees where the children +;;; of a node are the functions called by the node, or :caller-graph for +;;; trees where the children of a node are the functions the node calls. +;;; TYPES-TO-IGNORE is a list of funcall types (as specified in the +;;; patterns) to ignore in printing out the database. For example, +;;; '(:lisp) would ignore all calls to common lisp functions. COMPACT is +;;; a flag to tell the program to try to compact the trees a bit by not +;;; printing trees if they have already been seen. ROOT-NODES is a list +;;; of root nodes of trees to display. If ROOT-NODES is nil, tries to +;;; find all root nodes in the database. +;;; +;;; MAKE-CALLER-TREE (&optional (mode *default-graphing-mode*) [FUNCTION] +;;; (types-to-ignore *types-to-ignore*) +;;; compact) +;;; Outputs list structure of a tree which roughly represents the +;;; possibly cyclical structure of the caller database. +;;; If mode is :call-graph, the children of a node are the functions +;;; it calls. If mode is :caller-graph, the children of a node are the +;;; functions that call it. +;;; If compact is T, tries to eliminate the already-seen nodes, so +;;; that the graph for a node is printed at most once. Otherwise it will +;;; duplicate the node's tree (except for cycles). This is usefull +;;; because the call tree is actually a directed graph, so we can either +;;; duplicate references or display only the first one. +;;; +;;; DETERMINE-FILE-DEPENDENCIES (&optional database) [FUNCTION] +;;; Makes a hash table of file dependencies for the references listed in +;;; DATABASE. This function may be useful for automatically resolving +;;; file references for automatic creation of a system definition +;;; (defsystem). +;;; +;;; PRINT-FILE-DEPENDENCIES (&optional database) [FUNCTION] +;;; Prints a list of file dependencies for the references listed in +;;; DATABASE. This function may be useful for automatically computing +;;; file loading constraints for a system definition tool. +;;; +;;; WRITE-CALLERS-DATABASE-TO-FILE (filename) [FUNCTION] +;;; Saves the contents of the current callers database to a file. This +;;; file can be loaded to restore the previous contents of the +;;; database. (For large systems it can take a long time to crunch +;;; through the code, so this can save some time.) +;;; +;;; ----- +;;; The following macros define new function and macro call patterns. +;;; They may be used to extend the static analysis tool to handle +;;; new def forms, extensions to Common Lisp, and program defs. +;;; +;;; DEFINE-PATTERN-SUBSTITUTION (name pattern) [MACRO] +;;; Defines NAME to be equivalent to the specified pattern. Useful for +;;; making patterns more readable. For example, the LAMBDA-LIST is +;;; defined as a pattern substitution, making the definition of the +;;; DEFUN caller-pattern simpler. +;;; +;;; DEFINE-CALLER-PATTERN (name pattern &optional caller-type) [MACRO] +;;; Defines NAME as a function/macro call with argument structure +;;; described by PATTERN. CALLER-TYPE, if specified, assigns a type to +;;; the pattern, which may be used to exclude references to NAME while +;;; viewing the database. For example, all the Common Lisp definitions +;;; have a caller-type of :lisp or :lisp2, so that you can exclude +;;; references to common lisp functions from the calling tree. +;;; +;;; DEFINE-VARIABLE-PATTERN (name &optional caller-type) [MACRO] +;;; Defines NAME as a variable reference of type CALLER-TYPE. This is +;;; mainly used to establish the caller-type of the variable. +;;; +;;; DEFINE-CALLER-PATTERN-SYNONYMS (source destinations) [MACRO] +;;; For defining function caller pattern syntax synonyms. For each name +;;; in DESTINATIONS, defines its pattern as a copy of the definition +;;; of SOURCE. Allows a large number of identical patterns to be defined +;;; simultaneously. Must occur after the SOURCE has been defined. +;;; +;;; ----- +;;; This system includes pattern definitions for the latest +;;; common lisp specification, as published in Guy Steele, +;;; Common Lisp: The Language, 2nd Edition. +;;; +;;; Patterns may be either structures to match, or a predicate +;;; like symbolp/numberp/stringp. The pattern specification language +;;; is similar to the notation used in CLtL2, but in a more lisp-like +;;; form: +;;; (:eq name) The form element must be eq to the symbol NAME. +;;; (:test test) TEST must be true when applied to the form element. +;;; (:typep type) The form element must be of type TYPE. +;;; (:or pat1 pat2 ...) Tries each of the patterns in left-to-right order, +;;; until one succeeds. +;;; Equivalent to { pat1 | pat2 | ... } +;;; (:rest pattern) The remaining form elements are grouped into a +;;; list which is matched against PATTERN. +;;; (:optional pat1 ...) The patterns may optionally match against the +;;; form element. +;;; Equivalent to [ pat1 ... ]. +;;; (:star pat1 ...) The patterns may match against the patterns +;;; any number of times, including 0. +;;; Equivalent to { pat1 ... }*. +;;; (:plus pat1 ...) The patterns may match against the patterns +;;; any number of times, but at least once. +;;; Equivalent to { pat1 ... }+. +;;; &optional, &key, Similar in behavior to the corresponding +;;; &rest lambda-list keywords. +;;; FORM A random lisp form. If a cons, assumes the +;;; car is a function or macro and tries to +;;; match the args against that symbol's pattern. +;;; If a symbol, assumes it's a variable reference. +;;; :ignore Ignores the corresponding form element. +;;; NAME The corresponding form element should be +;;; the name of a new definition (e.g., the +;;; first arg in a defun pattern is NAME. +;;; FUNCTION, MACRO The corresponding form element should be +;;; a function reference not handled by FORM. +;;; Used in the definition of apply and funcall. +;;; VAR The corresponding form element should be +;;; a variable definition or mutation. Used +;;; in the definition of let, let*, etc. +;;; VARIABLE The corresponding form element should be +;;; a variable reference. +;;; +;;; In all other pattern symbols, it looks up the symbols pattern substitution +;;; and recursively matches against the pattern. Automatically destructures +;;; list structure that does not include consing dots. +;;; +;;; Among the pattern substitution names defined are: +;;; STRING, SYMBOL, NUMBER Appropriate :test patterns. +;;; LAMBDA-LIST Matches against a lambda list. +;;; BODY Matches against a function body definition. +;;; FN Matches against #'function, 'function, +;;; and lambdas. This is used in the definition +;;; of apply, funcall, and the mapping patterns. +;;; and others... +;;; +;;; Here's some sample pattern definitions: +;;; (define-caller-pattern defun +;;; (name lambda-list +;;; (:star (:or documentation-string declaration)) +;;; (:star form)) +;;; :lisp) +;;; (define-caller-pattern funcall (fn (:star form)) :lisp) +;;; +;;; In general, the system is intelligent enough to handle any sort of +;;; simple funcall. One only need specify the syntax for functions and +;;; macros which use optional arguments, keyword arguments, or some +;;; argument positions are special, such as in apply and funcall, or +;;; to indicate that the function is of the specified caller type. +;;; +;;; +;;; NOTES: +;;; +;;; XRef assumes syntactically correct lisp code. +;;; +;;; This is by no means perfect. For example, let and let* are treated +;;; identically, instead of differentiating between serial and parallel +;;; binding. But it's still a useful tool. It can be helpful in +;;; maintaining code, debugging problems with patch files, determining +;;; whether functions are multiply defined, and help you remember where +;;; a function is defined or called. +;;; +;;; XREF runs best when compiled. + +;;; ******************************** +;;; References ********************* +;;; ******************************** +;;; +;;; Xerox Interlisp Masterscope Program: +;;; Larry M Masinter, Global program analysis in an interactive environment +;;; PhD Thesis, Stanford University, 1980. +;;; +;;; Symbolics Who-Calls Database: +;;; User's Guide to Symbolics Computers, Volume 1, Cambridge, MA, July 1986 +;;; Genera 7.0, pp 183-185. +;;; + +;;; ******************************** +;;; Example ************************ +;;; ******************************** +;;; +;;; Here is an example of running XREF on a short program. +;;; [In Scribe documentation, give a simple short program and resulting +;;; XREF output, including postscript call graphs.] +#| +<cl> (xref:xref-file "/afs/cs/user/mkant/Lisp/Graph-Dag/graph-dag.lisp") +Cross-referencing file /afs/cs/user/mkant/Lisp/Graph-Dag/graph-dag.lisp. +................................................ +48 forms processed. +<cl> (xref:display-database :readers) + +*DISPLAY-CUTOFF-DEPTH* is referenced by CALCULATE-LEVEL-POSITION +CALCULATE-LEVEL-POSITION-BEFORE CALCULATE-POSITION-IN-LEVEL. +*OFFSET-FROM-EDGE-OF-PANE* is referenced by CALCULATE-LEVEL-POSITION +CALCULATE-LEVEL-POSITION-BEFORE. +*WITHIN-LEVEL-SPACING* is referenced by BREADTH CALCULATE-POSITION-INFO. +*DIRECTION* is referenced by CREATE-POSITION-INFO. +*LINK-OFFSET* is referenced by OFFSET-OF-LINK-FROM-ATTACHMENT-POINT. +*ROOT-IS-SEQUENCE* is referenced by GRAPH. +*LEVEL-SPACING* is referenced by CALCULATE-LEVEL-POSITION +CALCULATE-LEVEL-POSITION-BEFORE. +*ORIENTATION* is referenced by BREADTH CALCULATE-LEVEL-POSITION +CALCULATE-LEVEL-POSITION-BEFORE CALCULATE-POSITION-IN-LEVEL. +*DEFAULT-GRAPH-POSITION* is referenced by CREATE-POSITION-INFO. +*GRAPHING-CUTOFF-DEPTH* is referenced by CREATE-NODE-STRUCTURE. +*LIST-OF-NODES* is referenced by CALCULATE-LEVEL-POSITION +CALCULATE-LEVEL-POSITION-BEFORE CREATE-NODE FIND-NODE. +*GRAPH-TYPE* is referenced by CREATE-NODE-STRUCTURE. +<cl> (xref:print-caller-trees :root-nodes '(display-graph)) + +Rooted calling trees: + DISPLAY-GRAPH + CREATE-POSITION-INFO + CALCULATE-POSITION-INFO + CALCULATE-POSITION + NODE-POSITION-ALREADY-SET-FLAG + NODE-LEVEL-ALREADY-SET-FLAG + CALCULATE-POSITION-IN-LEVEL + NODE-CHILDREN + NODE-LEVEL + CALCULATE-POSITION + NEW-CALCULATE-BREADTH + NODE-CHILDREN + BREADTH + OPPOSITE-DIMENSION + NODE-HEIGHT + NODE-WIDTH + NEW-CALCULATE-BREADTH + NODE-PARENTS + OPPOSITE-DIMENSION + NODE-HEIGHT + NODE-WIDTH + OPPOSITE-POSITION + NODE-Y + NODE-X + NODE-LEVEL + CALCULATE-LEVEL-POSITION + NODE-LEVEL + NODE-POSITION + NODE-X + NODE-Y + DIMENSION + NODE-WIDTH + NODE-HEIGHT + CALCULATE-LEVEL-POSITION-BEFORE + NODE-LEVEL + NODE-POSITION + NODE-X + NODE-Y + NODE-WIDTH + NODE-HEIGHT + DIMENSION + NODE-WIDTH + NODE-HEIGHT +|# + +;;; **************************************************************** +;;; List Callers *************************************************** +;;; **************************************************************** + +(defpackage :pxref + (:use :common-lisp) + (:export #:list-callers + #:list-users + #:list-readers + #:list-setters + #:what-files-call + #:who-calls + #:list-callees + #:source-file + #:clear-tables + #:define-pattern-substitution + #:define-caller-pattern + #:define-variable-pattern + #:define-caller-pattern-synonyms + #:clear-patterns + #:*last-form* + #:*xref-verbose* + #:*handle-package-forms* + #:*handle-function-forms* + #:*handle-macro-forms* + #:*types-to-ignore* + #:*last-caller-tree* + #:*default-graphing-mode* + #:*indent-amount* + #:xref-file + #:xref-files + #:write-callers-database-to-file + #:display-database + #:print-caller-trees + #:make-caller-tree + #:print-indented-tree + #:determine-file-dependencies + #:print-file-dependencies + #:psgraph-xref + )) + +(in-package "PXREF") + +;;; Warn user if they're loading the source instead of compiling it first. +;(eval-when (compile load eval) +; (defvar compiled-p nil)) +;(eval-when (compile load) +; (setq compiled-p t)) +;(eval-when (load eval) +; (unless compiled-p +; (warn "This file should be compiled before loading for best results."))) +(eval-when (eval) + (warn "This file should be compiled before loading for best results.")) + + +;;; ******************************** +;;; Primitives ********************* +;;; ******************************** +(defun lookup (symbol environment) + (dolist (frame environment) + (when (member symbol frame) + (return symbol)))) + +(defun car-eq (list item) + (and (consp list) + (eq (car list) item))) + +;;; ******************************** +;;; Callers Database *************** +;;; ******************************** +(defvar *file-callers-database* (make-hash-table :test #'equal) + "Contains name and list of file callers (files which call) for that name.") +(defvar *callers-database* (make-hash-table :test #'equal) + "Contains name and list of callers (function invocation) for that name.") +(defvar *readers-database* (make-hash-table :test #'equal) + "Contains name and list of readers (variable use) for that name.") +(defvar *setters-database* (make-hash-table :test #'equal) + "Contains name and list of setters (variable mutation) for that name.") +(defvar *callees-database* (make-hash-table :test #'equal) + "Contains name and list of functions and variables it calls.") +(defun callers-list (name &optional (database :callers)) + (case database + (:file (gethash name *file-callers-database*)) + (:callees (gethash name *callees-database*)) + (:callers (gethash name *callers-database*)) + (:readers (gethash name *readers-database*)) + (:setters (gethash name *setters-database*)))) +(defsetf callers-list (name &optional (database :callers)) (caller) + `(setf (gethash ,name (case ,database + (:file *file-callers-database*) + (:callees *callees-database*) + (:callers *callers-database*) + (:readers *readers-database*) + (:setters *setters-database*))) + ,caller)) + +(defun list-callers (symbol) + "Lists all functions which call SYMBOL as a function (function invocation)." + (callers-list symbol :callers)) +(defun list-readers (symbol) + "Lists all functions which refer to SYMBOL as a variable + (variable reference)." + (callers-list symbol :readers)) +(defun list-setters (symbol) + "Lists all functions which bind/set SYMBOL as a variable + (variable mutation)." + (callers-list symbol :setters)) +(defun list-users (symbol) + "Lists all functions which use SYMBOL as a variable or function." + (values (list-callers symbol) + (list-readers symbol) + (list-setters symbol))) +(defun who-calls (symbol &optional how) + "Lists callers of symbol. HOW may be :function, :reader, :setter, + or :variable." + ;; would be nice to have :macro and distinguish variable + ;; binding from assignment. (i.e., variable binding, assignment, and use) + (case how + (:function (list-callers symbol)) + (:reader (list-readers symbol)) + (:setter (list-setters symbol)) + (:variable (append (list-readers symbol) + (list-setters symbol))) + (otherwise (append (list-callers symbol) + (list-readers symbol) + (list-setters symbol))))) +(defun what-files-call (symbol) + "Lists names of files that contain uses of SYMBOL + as a function, variable, or constant." + (callers-list symbol :file)) +(defun list-callees (symbol) + "Lists names of functions and variables called by SYMBOL." + (callers-list symbol :callees)) + +(defvar *source-file* (make-hash-table :test #'equal) + "Contains function name and source file for that name.") +(defun source-file (symbol) + "Lists the names of files in which SYMBOL is defined/used." + (gethash symbol *source-file*)) +(defsetf source-file (name) (value) + `(setf (gethash ,name *source-file*) ,value)) + +(defun clear-tables () + (clrhash *file-callers-database*) + (clrhash *callers-database*) + (clrhash *callees-database*) + (clrhash *readers-database*) + (clrhash *setters-database*) + (clrhash *source-file*)) + + +;;; ******************************** +;;; Pattern Database *************** +;;; ******************************** +;;; Pattern Types +(defvar *pattern-caller-type* (make-hash-table :test #'equal)) +(defun pattern-caller-type (name) + (gethash name *pattern-caller-type*)) +(defsetf pattern-caller-type (name) (value) + `(setf (gethash ,name *pattern-caller-type*) ,value)) + +;;; Pattern Substitutions +(defvar *pattern-substitution-table* (make-hash-table :test #'equal) + "Stores general patterns for function destructuring.") +(defun lookup-pattern-substitution (name) + (gethash name *pattern-substitution-table*)) +(defmacro define-pattern-substitution (name pattern) + "Defines NAME to be equivalent to the specified pattern. Useful for + making patterns more readable. For example, the LAMBDA-LIST is + defined as a pattern substitution, making the definition of the + DEFUN caller-pattern simpler." + `(setf (gethash ',name *pattern-substitution-table*) + ',pattern)) + +;;; Function/Macro caller patterns: +;;; The car of the form is skipped, so we don't need to specify +;;; (:eq function-name) like we would for a substitution. +;;; +;;; Patterns must be defined in the XREF package because the pattern +;;; language is tested by comparing symbols (using #'equal) and not +;;; their printreps. This is fine for the lisp grammer, because the XREF +;;; package depends on the LISP package, so a symbol like 'xref::cons is +;;; translated automatically into 'lisp::cons. However, since +;;; (equal 'foo::bar 'baz::bar) returns nil unless both 'foo::bar and +;;; 'baz::bar are inherited from the same package (e.g., LISP), +;;; if package handling is turned on the user must specify package +;;; names in the caller pattern definitions for functions that occur +;;; in packages other than LISP, otherwise the symbols will not match. +;;; +;;; Perhaps we should enforce the definition of caller patterns in the +;;; XREF package by wrapping the body of define-caller-pattern in +;;; the XREF package: +;;; (defmacro define-caller-pattern (name value &optional caller-type) +;;; (let ((old-package *package*)) +;;; (setf *package* (find-package "XREF")) +;;; (prog1 +;;; `(progn +;;; (when ',caller-type +;;; (setf (pattern-caller-type ',name) ',caller-type)) +;;; (when ',value +;;; (setf (gethash ',name *caller-pattern-table*) +;;; ',value))) +;;; (setf *package* old-package)))) +;;; Either that, or for the purpose of pattern testing we should compare +;;; printreps. [The latter makes the primitive patterns like VAR +;;; reserved words.] +(defvar *caller-pattern-table* (make-hash-table :test #'equal) + "Stores patterns for function destructuring.") +(defun lookup-caller-pattern (name) + (gethash name *caller-pattern-table*)) +(defmacro define-caller-pattern (name pattern &optional caller-type) + "Defines NAME as a function/macro call with argument structure + described by PATTERN. CALLER-TYPE, if specified, assigns a type to + the pattern, which may be used to exclude references to NAME while + viewing the database. For example, all the Common Lisp definitions + have a caller-type of :lisp or :lisp2, so that you can exclude + references to common lisp functions from the calling tree." + `(progn + (when ',caller-type + (setf (pattern-caller-type ',name) ',caller-type)) + (when ',pattern + (setf (gethash ',name *caller-pattern-table*) + ',pattern)))) + +;;; For defining variables +(defmacro define-variable-pattern (name &optional caller-type) + "Defines NAME as a variable reference of type CALLER-TYPE. This is + mainly used to establish the caller-type of the variable." + `(progn + (when ',caller-type + (setf (pattern-caller-type ',name) ',caller-type)))) + +;;; For defining synonyms. Means much less space taken up by the patterns. +(defmacro define-caller-pattern-synonyms (source destinations) + "For defining function caller pattern syntax synonyms. For each name + in DESTINATIONS, defines its pattern as a copy of the definition of SOURCE. + Allows a large number of identical patterns to be defined simultaneously. + Must occur after the SOURCE has been defined." + `(let ((source-type (pattern-caller-type ',source)) + (source-pattern (gethash ',source *caller-pattern-table*))) + (when source-type + (dolist (dest ',destinations) + (setf (pattern-caller-type dest) source-type))) + (when source-pattern + (dolist (dest ',destinations) + (setf (gethash dest *caller-pattern-table*) + source-pattern))))) + +(defun clear-patterns () + (clrhash *pattern-substitution-table*) + (clrhash *caller-pattern-table*) + (clrhash *pattern-caller-type*)) + +;;; ******************************** +;;; Cross Reference Files ********** +;;; ******************************** +(defvar *last-form* () + "The last form read from the file. Useful for figuring out what went wrong + when xref-file drops into the debugger.") + +(defvar *xref-verbose* t + "When T, xref-file(s) prints out the names of the files it looks at, + progress dots, and the number of forms read.") + +;;; This needs to first clear the tables? +(defun xref-files (&rest files) + "Grovels over the lisp code located in source file FILES, using xref-file." + ;; If the arg is a list, use it. + (when (listp (car files)) (setq files (car files))) + (dolist (file files) + (xref-file file nil)) + (values)) + +(defvar *handle-package-forms* nil ;'(lisp::in-package) + "When non-NIL, and XREF-FILE sees a package-setting form like IN-PACKAGE, + sets the current package to the specified package by evaluating the + form. When done with the file, xref-file resets the package to its + original value. In some of the displaying functions, when this variable + is non-NIL one may specify that all symbols from a particular set of + packages be ignored. This is only useful if the files use different + packages with conflicting names.") + +(defvar *normal-readtable* (copy-readtable nil) + "Normal, unadulterated CL readtable.") + +(defun xref-file (filename &optional (clear-tables t) (verbose *xref-verbose*)) + "Cross references the function and variable calls in FILENAME by + walking over the source code located in the file. Defaults type of + filename to \".lisp\". Chomps on the code using record-callers and + record-callers*. If CLEAR-TABLES is T (the default), it clears the callers + database before processing the file. Specify CLEAR-TABLES as nil to + append to the database. If VERBOSE is T (the default), prints out the + name of the file, one progress dot for each form processed, and the + total number of forms." + ;; Default type to "lisp" + (when (and (null (pathname-type filename)) + (not (probe-file filename))) + (cond ((stringp filename) + (setf filename (concatenate 'string filename ".lisp"))) + ((pathnamep filename) + (setf filename (merge-pathnames filename + (make-pathname :type "lisp")))))) + (when clear-tables (clear-tables)) + (let ((count 0) + (old-package *package*) + (*readtable* *normal-readtable*)) + (when verbose + (format t "~&Cross-referencing file ~A.~&" filename)) + (with-open-file (stream filename :direction :input) + (do ((form (read stream nil :eof) (read stream nil :eof))) + ((eq form :eof)) + (incf count) + (when verbose + (format *standard-output* ".") + (force-output *standard-output*)) + (setq *last-form* form) + (record-callers filename form) + ;; Package Magic. + (when (and *handle-package-forms* + (consp form) + (member (car form) *handle-package-forms*)) + (eval form)))) + (when verbose + (format t "~&~D forms processed." count)) + (setq *package* old-package) + (values))) + +(defvar *handle-function-forms* t + "When T, XREF-FILE tries to be smart about forms which occur in + a function position, such as lambdas and arbitrary Lisp forms. + If so, it recursively calls record-callers with pattern 'FORM. + If the form is a lambda, makes the caller a caller of :unnamed-lambda.") + +(defvar *handle-macro-forms* t + "When T, if the file was loaded before being processed by XREF, and the + car of a form is a macro, it notes that the parent calls the macro, + and then calls macroexpand-1 on the form.") + +(defvar *callees-database-includes-variables* nil) + +(defun record-callers (filename form + &optional pattern parent (environment nil) + funcall) + "RECORD-CALLERS is the main routine used to walk down the code. It matches + the PATTERN against the FORM, possibly adding statements to the database. + PARENT is the name defined by the current outermost definition; it is + the caller of the forms in the body (e.g., FORM). ENVIRONMENT is used + to keep track of the scoping of variables. FUNCALL deals with the type + of variable assignment and hence how the environment should be modified. + RECORD-CALLERS handles atomic patterns and simple list-structure patterns. + For complex list-structure pattern destructuring, it calls RECORD-CALLERS*." +; (when form) + (unless pattern (setq pattern 'FORM)) + (cond ((symbolp pattern) + (case pattern + (:IGNORE + ;; Ignores the rest of the form. + (values t parent environment)) + (NAME + ;; This is the name of a new definition. + (push filename (source-file form)) + (values t form environment)) + ((FUNCTION MACRO) + ;; This is the name of a call. + (cond ((and *handle-function-forms* (consp form)) + ;; If we're a cons and special handling is on, + (when (eq (car form) 'lambda) + (pushnew filename (callers-list :unnamed-lambda :file)) + (when parent + (pushnew parent (callers-list :unnamed-lambda + :callers)) + (pushnew :unnamed-lambda (callers-list parent + :callees)))) + (record-callers filename form 'form parent environment)) + (t + ;; If we're just a regular function name call. + (pushnew filename (callers-list form :file)) + (when parent + (pushnew parent (callers-list form :callers)) + (pushnew form (callers-list parent :callees))) + (values t parent environment)))) + (VAR + ;; This is the name of a new variable definition. + ;; Includes arglist parameters. + (when (and (symbolp form) (not (keywordp form)) + (not (member form lambda-list-keywords))) + (pushnew form (car environment)) + (pushnew filename (callers-list form :file)) + (when parent +; (pushnew form (callers-list parent :callees)) + (pushnew parent (callers-list form :setters))) + (values t parent environment))) + (VARIABLE + ;; VAR reference + (pushnew filename (callers-list form :file)) + (when (and parent (not (lookup form environment))) + (pushnew parent (callers-list form :readers)) + (when *callees-database-includes-variables* + (pushnew form (callers-list parent :callees)))) + (values t parent environment)) + (FORM + ;; A random form (var or funcall). + (cond ((consp form) + ;; Get new pattern from TAG. + (let ((new-pattern (lookup-caller-pattern (car form)))) + (pushnew filename (callers-list (car form) :file)) + (when parent + (pushnew parent (callers-list (car form) :callers)) + (pushnew (car form) (callers-list parent :callees))) + (cond ((and new-pattern (cdr form)) + ;; Special Pattern and there's stuff left + ;; to be processed. Note that we check if + ;; a pattern is defined for the form before + ;; we check to see if we can macroexpand it. + (record-callers filename (cdr form) new-pattern + parent environment :funcall)) + ((and *handle-macro-forms* + (symbolp (car form)) ; pnorvig 9/9/93 + (macro-function (car form))) + ;; The car of the form is a macro and + ;; macro processing is turned on. Macroexpand-1 + ;; the form and try again. + (record-callers filename + (macroexpand-1 form) + 'form parent environment + :funcall)) + ((null (cdr form)) + ;; No more left to be processed. Note that + ;; this must occur after the macros clause, + ;; since macros can expand into more code. + (values t parent environment)) + (t + ;; Random Form. We assume it is a function call. + (record-callers filename (cdr form) + '((:star FORM)) + parent environment :funcall))))) + (t + (when (and (not (lookup form environment)) + (not (numberp form)) + ;; the following line should probably be + ;; commented out? + (not (keywordp form)) + (not (stringp form)) + (not (eq form t)) + (not (eq form nil))) + (pushnew filename (callers-list form :file)) + ;; ??? :callers + (when parent + (pushnew parent (callers-list form :readers)) + (when *callees-database-includes-variables* + (pushnew form (callers-list parent :callees))))) + (values t parent environment)))) + (otherwise + ;; Pattern Substitution + (let ((new-pattern (lookup-pattern-substitution pattern))) + (if new-pattern + (record-callers filename form new-pattern + parent environment) + (when (eq pattern form) + (values t parent environment))))))) + ((consp pattern) + (case (car pattern) + (:eq (when (eq (second pattern) form) + (values t parent environment))) + (:test (when (funcall (eval (second pattern)) form) + (values t parent environment))) + (:typep (when (typep form (second pattern)) + (values t parent environment))) + (:or (dolist (subpat (rest pattern)) + (multiple-value-bind (processed parent environment) + (record-callers filename form subpat + parent environment) + (when processed + (return (values processed parent environment)))))) + (:rest ; (:star :plus :optional :rest) + (record-callers filename form (second pattern) + parent environment)) + (otherwise + (multiple-value-bind (d p env) + (record-callers* filename form pattern + parent (cons nil environment)) + (values d p (if funcall environment env)))))))) + +(defun record-callers* (filename form pattern parent environment + &optional continuation + in-optionals in-keywords) + "RECORD-CALLERS* handles complex list-structure patterns, such as + ordered lists of subpatterns, patterns involving :star, :plus, + &optional, &key, &rest, and so on. CONTINUATION is a stack of + unprocessed patterns, IN-OPTIONALS and IN-KEYWORDS are corresponding + stacks which determine whether &rest or &key has been seen yet in + the current pattern." + ;; form must be a cons or nil. +; (when form) + (if (null pattern) + (if (null continuation) + (values t parent environment) + (record-callers* filename form (car continuation) parent environment + (cdr continuation) + (cdr in-optionals) + (cdr in-keywords))) + (let ((pattern-elt (car pattern))) + (cond ((car-eq pattern-elt :optional) + (if (null form) + (values t parent environment) + (multiple-value-bind (processed par env) + (record-callers* filename form (cdr pattern-elt) + parent environment + (cons (cdr pattern) continuation) + (cons (car in-optionals) in-optionals) + (cons (car in-keywords) in-keywords)) + (if processed + (values processed par env) + (record-callers* filename form (cdr pattern) + parent environment continuation + in-optionals in-keywords))))) + ((car-eq pattern-elt :star) + (if (null form) + (values t parent environment) + (multiple-value-bind (processed par env) + (record-callers* filename form (cdr pattern-elt) + parent environment + (cons pattern continuation) + (cons (car in-optionals) in-optionals) + (cons (car in-keywords) in-keywords)) + (if processed + (values processed par env) + (record-callers* filename form (cdr pattern) + parent environment continuation + in-optionals in-keywords))))) + ((car-eq pattern-elt :plus) + (record-callers* filename form (cdr pattern-elt) + parent environment + (cons (cons (cons :star (cdr pattern-elt)) + (cdr pattern)) + continuation) + (cons (car in-optionals) in-optionals) + (cons (car in-keywords) in-keywords))) + ((car-eq pattern-elt :rest) + (record-callers filename form pattern-elt parent environment)) + ((eq pattern-elt '&optional) + (record-callers* filename form (cdr pattern) + parent environment continuation + (cons t in-optionals) + (cons (car in-keywords) in-keywords))) + ((eq pattern-elt '&rest) + (record-callers filename form (second pattern) + parent environment)) + ((eq pattern-elt '&key) + (record-callers* filename form (cdr pattern) + parent environment continuation + (cons (car in-optionals) in-optionals) + (cons t in-keywords))) + ((null form) + (when (or (car in-keywords) (car in-optionals)) + (values t parent environment))) + ((consp form) + (multiple-value-bind (processed parent environment) + (record-callers filename (if (car in-keywords) + (cadr form) + (car form)) + pattern-elt + parent environment) + (cond (processed + (record-callers* filename (if (car in-keywords) + (cddr form) + (cdr form)) + (cdr pattern) + parent environment + continuation + in-optionals in-keywords)) + ((or (car in-keywords) + (car in-optionals)) + (values t parent environment))))))))) + + +;;; ******************************** +;;; Misc Utilities ***************** +;;; ******************************** +(defvar *types-to-ignore* + '(:lisp ; CLtL 1st Edition + :lisp2 ; CLtL 2nd Edition additional patterns + ) + "Default set of caller types (as specified in the patterns) to ignore + in the database handling functions. :lisp is CLtL 1st edition, + :lisp2 is additional patterns from CLtL 2nd edition.") + +(defun display-database (&optional (database :callers) + (types-to-ignore *types-to-ignore*)) + "Prints out the name of each symbol and all its callers. Specify database + :callers (the default) to get function call references, :fill to the get + files in which the symbol is called, :readers to get variable references, + and :setters to get variable binding and assignments. Ignores functions + of types listed in types-to-ignore." + (maphash #'(lambda (name callers) + (unless (or (member (pattern-caller-type name) + types-to-ignore) + ;; When we're doing fancy package crap, + ;; allow us to ignore symbols based on their + ;; packages. + (when *handle-package-forms* + (member (symbol-package name) + types-to-ignore + :key #'find-package))) + (format t "~&~S is referenced by~{ ~S~}." + name callers))) + (ecase database + (:file *file-callers-database*) + (:callers *callers-database*) + (:readers *readers-database*) + (:setters *setters-database*)))) + +(defun write-callers-database-to-file (filename) + "Saves the contents of the current callers database to a file. This + file can be loaded to restore the previous contents of the + database. (For large systems it can take a long time to crunch + through the code, so this can save some time.)" + (with-open-file (stream filename :direction :output) + (format stream "~&(clear-tables)") + (maphash #'(lambda (x y) + (format stream "~&(setf (source-file '~S) '~S)" + x y)) + *source-file*) + (maphash #'(lambda (x y) + (format stream "~&(setf (callers-list '~S :file) '~S)" + x y)) + *file-callers-database*) + (maphash #'(lambda (x y) + (format stream "~&(setf (callers-list '~S :callers) '~S)" + x y)) + *callers-database*) + (maphash #'(lambda (x y) + (format stream "~&(setf (callers-list '~S :callees) '~S)" + x y)) + *callees-database*) + (maphash #'(lambda (x y) + (format stream "~&(setf (callers-list '~S :readers) '~S)" + x y)) + *readers-database*) + (maphash #'(lambda (x y) + (format stream "~&(setf (callers-list '~S :setters) '~S)" + x y)) + *setters-database*))) + + +;;; ******************************** +;;; Print Caller Trees ************* +;;; ******************************** +;;; The following function is useful for reversing a caller table into +;;; a callee table. Possibly later we'll extend xref to create two +;;; such database hash tables. Needs to include vars as well. +(defun invert-hash-table (table &optional (types-to-ignore *types-to-ignore*)) + "Makes a copy of the hash table in which (name value*) pairs + are inverted to (value name*) pairs." + (let ((target (make-hash-table :test #'equal))) + (maphash #'(lambda (key values) + (dolist (value values) + (unless (member (pattern-caller-type key) + types-to-ignore) + (pushnew key (gethash value target))))) + table) + target)) + +;;; Resolve file references for automatic creation of a defsystem file. +(defun determine-file-dependencies (&optional (database *callers-database*)) + "Makes a hash table of file dependencies for the references listed in + DATABASE. This function may be useful for automatically resolving + file references for automatic creation of a system definition (defsystem)." + (let ((file-ref-ht (make-hash-table :test #'equal))) + (maphash #'(lambda (key values) + (let ((key-file (source-file key))) + (when key + (dolist (value values) + (let ((value-file (source-file value))) + (when value-file + (dolist (s key-file) + (dolist (d value-file) + (pushnew d (gethash s file-ref-ht)))))))))) + database) + file-ref-ht)) + +(defun print-file-dependencies (&optional (database *callers-database*)) + "Prints a list of file dependencies for the references listed in DATABASE. + This function may be useful for automatically computing file loading + constraints for a system definition tool." + (maphash #'(lambda (key value) (format t "~&~S --> ~S" key value)) + (determine-file-dependencies database))) + +;;; The following functions demonstrate a possible way to interface +;;; xref to a graphical browser such as psgraph to mimic the capabilities +;;; of Masterscope's graphical browser. + +(defvar *last-caller-tree* nil) + +(defvar *default-graphing-mode* :call-graph + "Specifies whether we graph up or down. If :call-graph, the children + of a node are the functions it calls. If :caller-graph, the children + of a node are the functions that call it.") + +(defun gather-tree (parents &optional already-seen + (mode *default-graphing-mode*) + (types-to-ignore *types-to-ignore*) compact) + "Extends the tree, copying it into list structure, until it repeats + a reference (hits a cycle)." + (let ((*already-seen* nil) + (database (case mode + (:call-graph *callees-database*) + (:caller-graph *callers-database*)))) + (declare (special *already-seen*)) + (labels + ((amass-tree + (parents &optional already-seen) + (let (result this-item) + (dolist (parent parents) + (unless (member (pattern-caller-type parent) + types-to-ignore) + (pushnew parent *already-seen*) + (if (member parent already-seen) + (setq this-item nil) ; :ignore + (if compact + (multiple-value-setq (this-item already-seen) + (amass-tree (gethash parent database) + (cons parent already-seen))) + (setq this-item + (amass-tree (gethash parent database) + (cons parent already-seen))))) + (setq parent (format nil "~S" parent)) + (when (consp parent) (setq parent (cons :xref-list parent))) + (unless (eq this-item :ignore) + (push (if this-item + (list parent this-item) + parent) + result)))) + (values result ;(reverse result) + already-seen)))) + (values (amass-tree parents already-seen) + *already-seen*)))) + +(defun find-roots-and-cycles (&optional (mode *default-graphing-mode*) + (types-to-ignore *types-to-ignore*)) + "Returns a list of uncalled callers (roots) and called callers (potential + cycles)." + (let ((uncalled-callers nil) + (called-callers nil) + (database (ecase mode + (:call-graph *callers-database*) + (:caller-graph *callees-database*))) + (other-database (ecase mode + (:call-graph *callees-database*) + (:caller-graph *callers-database*)))) + (maphash #'(lambda (name value) + (declare (ignore value)) + (unless (member (pattern-caller-type name) + types-to-ignore) + (if (gethash name database) + (push name called-callers) + (push name uncalled-callers)))) + other-database) + (values uncalled-callers called-callers))) + +(defun make-caller-tree (&optional (mode *default-graphing-mode*) + (types-to-ignore *types-to-ignore*) compact) + "Outputs list structure of a tree which roughly represents the possibly + cyclical structure of the caller database. + If mode is :call-graph, the children of a node are the functions it calls. + If mode is :caller-graph, the children of a node are the functions that + call it. + If compact is T, tries to eliminate the already-seen nodes, so that + the graph for a node is printed at most once. Otherwise it will duplicate + the node's tree (except for cycles). This is usefull because the call tree + is actually a directed graph, so we can either duplicate references or + display only the first one." + ;; Would be nice to print out line numbers and whenever we skip a duplicated + ;; reference, print the line number of the full reference after the node. + (multiple-value-bind (uncalled-callers called-callers) + (find-roots-and-cycles mode types-to-ignore) + (multiple-value-bind (trees already-seen) + (gather-tree uncalled-callers nil mode types-to-ignore compact) + (setq *last-caller-tree* trees) + (let ((more-trees (gather-tree (set-difference called-callers + already-seen) + already-seen + mode types-to-ignore compact))) + (values trees more-trees))))) + +(defvar *indent-amount* 3 + "Number of spaces to indent successive levels in PRINT-INDENTED-TREE.") + +(defun print-indented-tree (trees &optional (indent 0)) + "Simple code to print out a list-structure tree (such as those created + by make-caller-tree) as indented text." + (when trees + (dolist (tree trees) + (cond ((and (listp tree) (eq (car tree) :xref-list)) + (format t "~&~VT~A" indent (cdr tree))) + ((listp tree) + (format t "~&~VT~A" indent (car tree)) + (print-indented-tree (cadr tree) (+ indent *indent-amount*))) + (t + (format t "~&~VT~A" indent tree)))))) + +(defun print-caller-trees (&key (mode *default-graphing-mode*) + (types-to-ignore *types-to-ignore*) + compact + root-nodes) + "Prints the calling trees (which may actually be a full graph and not + necessarily a DAG) as indented text trees using PRINT-INDENTED-TREE. + MODE is :call-graph for trees where the children of a node are the + functions called by the node, or :caller-graph for trees where the + children of a node are the functions the node calls. TYPES-TO-IGNORE + is a list of funcall types (as specified in the patterns) to ignore + in printing out the database. For example, '(:lisp) would ignore all + calls to common lisp functions. COMPACT is a flag to tell the program + to try to compact the trees a bit by not printing trees if they have + already been seen. ROOT-NODES is a list of root nodes of trees to + display. If ROOT-NODES is nil, tries to find all root nodes in the + database." + (multiple-value-bind (rooted cycles) + (if root-nodes + (values (gather-tree root-nodes nil mode types-to-ignore compact)) + (make-caller-tree mode types-to-ignore compact)) + (when rooted + (format t "~&Rooted calling trees:") + (print-indented-tree rooted 2)) + (when cycles + (when rooted + (format t "~2%")) + (format t "~&Cyclic calling trees:") + (print-indented-tree cycles 2)))) + + +;;; ******************************** +;;; Interface to PSGraph *********** +;;; ******************************** +#| +;;; Interface to Bates' PostScript Graphing Utility +(load "/afs/cs/user/mkant/Lisp/PSGraph/psgraph") + +(defparameter *postscript-output-directory* "") +(defun psgraph-xref (&key (mode *default-graphing-mode*) + (output-directory *postscript-output-directory*) + (types-to-ignore *types-to-ignore*) + (compact t) + (shrink t) + root-nodes + insert) + ;; If root-nodes is a non-nil list, uses that list as the starting + ;; position. Otherwise tries to find all roots in the database. + (multiple-value-bind (rooted cycles) + (if root-nodes + (values (gather-tree root-nodes nil mode types-to-ignore compact)) + (make-caller-tree mode types-to-ignore compact)) + (psgraph-output (append rooted cycles) output-directory shrink insert))) + +(defun psgraph-output (list-of-trees directory shrink &optional insert) + (let ((psgraph:*fontsize* 9) + (psgraph:*second-fontsize* 7) +; (psgraph:*boxkind* "fill") + (psgraph:*boxgray* "0") ; .8 + (psgraph:*edgewidth* "1") + (psgraph:*edgegray* "0")) + (labels ((stringify (thing) + (cond ((stringp thing) (string-downcase thing)) + ((symbolp thing) (string-downcase (symbol-name thing))) + ((and (listp thing) (eq (car thing) :xref-list)) + (stringify (cdr thing))) + ((listp thing) (stringify (car thing))) + (t (string thing))))) + (dolist (item list-of-trees) + (let* ((fname (stringify item)) + (filename (concatenate 'string directory + (string-trim '(#\: #\|) fname) + ".ps"))) + (format t "~&Creating PostScript file ~S." filename) + (with-open-file (*standard-output* filename + :direction :output + :if-does-not-exist :create + :if-exists :supersede) + ;; Note that the #'eq prints the DAG as a tree. If + ;; you replace it with #'equal, it will print it as + ;; a DAG, which I think is slightly ugly. + (psgraph:psgraph item + #'caller-tree-children #'caller-info shrink + insert #'eq))))))) + +(defun caller-tree-children (tree) + (when (and tree (listp tree) (not (eq (car tree) :xref-list))) + (cadr tree))) + +(defun caller-tree-node (tree) + (when tree + (cond ((and (listp tree) (eq (car tree) :xref-list)) + (cdr tree)) + ((listp tree) + (car tree)) + (t + tree)))) + +(defun caller-info (tree) + (let ((node (caller-tree-node tree))) + (list node))) +|# +#| +;;; Code to print out graphical trees of CLOS class hierarchies. +(defun print-class-hierarchy (&optional (start-class 'anything) + (file "classes.ps")) + (let ((start (find-class start-class))) + (when start + (with-open-file (*standard-output* file :direction :output) + (psgraph:psgraph start + #'clos::class-direct-subclasses + #'(lambda (x) + (list (format nil "~A" (clos::class-name x)))) + t nil #'eq))))) + +|# + + +;;; **************************************************************** +;;; Cross Referencing Patterns for Common Lisp ********************* +;;; **************************************************************** +(clear-patterns) + +;;; ******************************** +;;; Pattern Substitutions ********** +;;; ******************************** +(define-pattern-substitution integer (:test #'integerp)) +(define-pattern-substitution rational (:test #'rationalp)) +(define-pattern-substitution symbol (:test #'symbolp)) +(define-pattern-substitution string (:test #'stringp)) +(define-pattern-substitution number (:test #'numberp)) +(define-pattern-substitution lambda-list + ((:star var) + (:optional (:eq &optional) + (:star (:or var + (var (:optional form (:optional var)))))) + (:optional (:eq &rest) var) + (:optional (:eq &key) (:star (:or var + ((:or var + (keyword var)) + (:optional form (:optional var))))) + (:optional &allow-other-keys)) + (:optional (:eq &aux) + (:star (:or var + (var (:optional form))))))) +(define-pattern-substitution test form) +(define-pattern-substitution body + ((:star (:or declaration documentation-string)) + (:star form))) +(define-pattern-substitution documentation-string string) +(define-pattern-substitution initial-value form) +(define-pattern-substitution tag symbol) +(define-pattern-substitution declaration ((:eq declare)(:rest :ignore))) +(define-pattern-substitution destination form) +(define-pattern-substitution control-string string) +(define-pattern-substitution format-arguments + ((:star form))) +(define-pattern-substitution fn + (:or ((:eq quote) function) + ((:eq function) function) + function)) + +;;; ******************************** +;;; Caller Patterns **************** +;;; ******************************** + +;;; Types Related +(define-caller-pattern coerce (form :ignore) :lisp) +(define-caller-pattern type-of (form) :lisp) +(define-caller-pattern upgraded-array-element-type (:ignore) :lisp2) +(define-caller-pattern upgraded-complex-part-type (:ignore) :lisp2) + +;;; Lambdas and Definitions +(define-variable-pattern lambda-list-keywords :lisp) +(define-variable-pattern lambda-parameters-limit :lisp) +(define-caller-pattern lambda (lambda-list (:rest body)) :lisp) + +(define-caller-pattern defun + (name lambda-list + (:star (:or documentation-string declaration)) + (:star form)) + :lisp) + +;;; perhaps this should use VAR, instead of NAME +(define-caller-pattern defvar + (var (:optional initial-value (:optional documentation-string))) + :lisp) +(define-caller-pattern defparameter + (var initial-value (:optional documentation-string)) + :lisp) +(define-caller-pattern defconstant + (var initial-value (:optional documentation-string)) + :lisp) + +(define-caller-pattern eval-when + (:ignore ; the situations + (:star form)) + :lisp) + +;;; Logical Values +(define-variable-pattern nil :lisp) +(define-variable-pattern t :lisp) + +;;; Predicates +(define-caller-pattern typep (form form) :lisp) +(define-caller-pattern subtypep (form form) :lisp) + +(define-caller-pattern null (form) :lisp) +(define-caller-pattern symbolp (form) :lisp) +(define-caller-pattern atom (form) :lisp) +(define-caller-pattern consp (form) :lisp) +(define-caller-pattern listp (form) :lisp) +(define-caller-pattern numberp (form) :lisp) +(define-caller-pattern integerp (form) :lisp) +(define-caller-pattern rationalp (form) :lisp) +(define-caller-pattern floatp (form) :lisp) +(define-caller-pattern realp (form) :lisp2) +(define-caller-pattern complexp (form) :lisp) +(define-caller-pattern characterp (form) :lisp) +(define-caller-pattern stringp (form) :lisp) +(define-caller-pattern bit-vector-p (form) :lisp) +(define-caller-pattern vectorp (form) :lisp) +(define-caller-pattern simple-vector-p (form) :lisp) +(define-caller-pattern simple-string-p (form) :lisp) +(define-caller-pattern simple-bit-vector-p (form) :lisp) +(define-caller-pattern arrayp (form) :lisp) +(define-caller-pattern packagep (form) :lisp) +(define-caller-pattern functionp (form) :lisp) +(define-caller-pattern compiled-function-p (form) :lisp) +(define-caller-pattern commonp (form) :lisp) + +;;; Equality Predicates +(define-caller-pattern eq (form form) :lisp) +(define-caller-pattern eql (form form) :lisp) +(define-caller-pattern equal (form form) :lisp) +(define-caller-pattern equalp (form form) :lisp) + +;;; Logical Operators +(define-caller-pattern not (form) :lisp) +(define-caller-pattern or ((:star form)) :lisp) +(define-caller-pattern and ((:star form)) :lisp) + +;;; Reference + +;;; Quote is a problem. In Defmacro & friends, we'd like to actually +;;; look at the argument, 'cause it hides internal function calls +;;; of the defmacro. +(define-caller-pattern quote (:ignore) :lisp) + +(define-caller-pattern function ((:or fn form)) :lisp) +(define-caller-pattern symbol-value (form) :lisp) +(define-caller-pattern symbol-function (form) :lisp) +(define-caller-pattern fdefinition (form) :lisp2) +(define-caller-pattern boundp (form) :lisp) +(define-caller-pattern fboundp (form) :lisp) +(define-caller-pattern special-form-p (form) :lisp) + +;;; Assignment +(define-caller-pattern setq ((:star var form)) :lisp) +(define-caller-pattern psetq ((:star var form)) :lisp) +(define-caller-pattern set (form form) :lisp) +(define-caller-pattern makunbound (form) :lisp) +(define-caller-pattern fmakunbound (form) :lisp) + +;;; Generalized Variables +(define-caller-pattern setf ((:star form form)) :lisp) +(define-caller-pattern psetf ((:star form form)) :lisp) +(define-caller-pattern shiftf ((:plus form) form) :lisp) +(define-caller-pattern rotatef ((:star form)) :lisp) +(define-caller-pattern define-modify-macro + (name + lambda-list + fn + (:optional documentation-string)) + :lisp) +(define-caller-pattern defsetf + (:or (name name (:optional documentation-string)) + (name lambda-list (var) + (:star (:or declaration documentation-string)) + (:star form))) + :lisp) +(define-caller-pattern define-setf-method + (name lambda-list + (:star (:or declaration documentation-string)) + (:star form)) + :lisp) +(define-caller-pattern get-setf-method (form) :lisp) +(define-caller-pattern get-setf-method-multiple-value (form) :lisp) + + +;;; Function invocation +(define-caller-pattern apply (fn form (:star form)) :lisp) +(define-caller-pattern funcall (fn (:star form)) :lisp) + + +;;; Simple sequencing +(define-caller-pattern progn ((:star form)) :lisp) +(define-caller-pattern prog1 (form (:star form)) :lisp) +(define-caller-pattern prog2 (form form (:star form)) :lisp) + +;;; Variable bindings +(define-caller-pattern let + (((:star (:or var (var &optional form)))) + (:star declaration) + (:star form)) + :lisp) +(define-caller-pattern let* + (((:star (:or var (var &optional form)))) + (:star declaration) + (:star form)) + :lisp) +(define-caller-pattern compiler-let + (((:star (:or var (var form)))) + (:star form)) + :lisp) +(define-caller-pattern progv + (form form (:star form)) :lisp) +(define-caller-pattern flet + (((:star (name lambda-list + (:star (:or declaration + documentation-string)) + (:star form)))) + (:star form)) + :lisp) +(define-caller-pattern labels + (((:star (name lambda-list + (:star (:or declaration + documentation-string)) + (:star form)))) + (:star form)) + :lisp) +(define-caller-pattern macrolet + (((:star (name lambda-list + (:star (:or declaration + documentation-string)) + (:star form)))) + (:star form)) + :lisp) +(define-caller-pattern symbol-macrolet + (((:star (var form))) (:star declaration) (:star form)) + :lisp2) + +;;; Conditionals +(define-caller-pattern if (test form (:optional form)) :lisp) +(define-caller-pattern when (test (:star form)) :lisp) +(define-caller-pattern unless (test (:star form)) :lisp) +(define-caller-pattern cond ((:star (test (:star form)))) :lisp) +(define-caller-pattern case + (form + (:star ((:or symbol + ((:star symbol))) + (:star form)))) + :lisp) +(define-caller-pattern typecase (form (:star (symbol (:star form)))) + :lisp) + +;;; Blocks and Exits +(define-caller-pattern block (name (:star form)) :lisp) +(define-caller-pattern return-from (function (:optional form)) :lisp) +(define-caller-pattern return ((:optional form)) :lisp) + +;;; Iteration +(define-caller-pattern loop ((:star form)) :lisp) +(define-caller-pattern do + (((:star (:or var + (var (:optional form (:optional form)))))) ; init step + (form (:star form)) ; end-test result + (:star declaration) + (:star (:or tag form))) ; statement + :lisp) +(define-caller-pattern do* + (((:star (:or var + (var (:optional form (:optional form)))))) + (form (:star form)) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern dolist + ((var form (:optional form)) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern dotimes + ((var form (:optional form)) + (:star declaration) + (:star (:or tag form))) + :lisp) + +;;; Mapping +(define-caller-pattern mapcar (fn form (:star form)) :lisp) +(define-caller-pattern maplist (fn form (:star form)) :lisp) +(define-caller-pattern mapc (fn form (:star form)) :lisp) +(define-caller-pattern mapl (fn form (:star form)) :lisp) +(define-caller-pattern mapcan (fn form (:star form)) :lisp) +(define-caller-pattern mapcon (fn form (:star form)) :lisp) + +;;; The "Program Feature" +(define-caller-pattern tagbody ((:star (:or tag form))) :lisp) +(define-caller-pattern prog + (((:star (:or var (var (:optional form))))) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern prog* + (((:star (:or var (var (:optional form))))) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern go (tag) :lisp) + +;;; Multiple Values +(define-caller-pattern values ((:star form)) :lisp) +(define-variable-pattern multiple-values-limit :lisp) +(define-caller-pattern values-list (form) :lisp) +(define-caller-pattern multiple-value-list (form) :lisp) +(define-caller-pattern multiple-value-call (fn (:star form)) :lisp) +(define-caller-pattern multiple-value-prog1 (form (:star form)) :lisp) +(define-caller-pattern multiple-value-bind + (((:star var)) form + (:star declaration) + (:star form)) + :lisp) +(define-caller-pattern multiple-value-setq (((:star var)) form) :lisp) +(define-caller-pattern nth-value (form form) :lisp2) + +;;; Dynamic Non-Local Exits +(define-caller-pattern catch (tag (:star form)) :lisp) +(define-caller-pattern throw (tag form) :lisp) +(define-caller-pattern unwind-protect (form (:star form)) :lisp) + +;;; Macros +(define-caller-pattern macro-function (form) :lisp) +(define-caller-pattern defmacro + (name + lambda-list + (:star (:or declaration documentation-string)) + (:star form)) + :lisp) +(define-caller-pattern macroexpand (form (:optional :ignore)) :lisp) +(define-caller-pattern macroexpand-1 (form (:optional :ignore)) :lisp) +(define-variable-pattern *macroexpand-hook* :lisp) + +;;; Destructuring +(define-caller-pattern destructuring-bind + (lambda-list form + (:star declaration) + (:star form)) + :lisp2) + +;;; Compiler Macros +(define-caller-pattern define-compiler-macro + (name lambda-list + (:star (:or declaration documentation-string)) + (:star form)) + :lisp2) +(define-caller-pattern compiler-macro-function (form) :lisp2) +(define-caller-pattern compiler-macroexpand (form (:optional :ignore)) :lisp2) +(define-caller-pattern compiler-macroexpand-1 (form (:optional :ignore)) + :lisp2) + +;;; Environments +(define-caller-pattern variable-information (form &optional :ignore) + :lisp2) +(define-caller-pattern function-information (fn &optional :ignore) :lisp2) +(define-caller-pattern declaration-information (form &optional :ignore) :lisp2) +(define-caller-pattern augment-environment (form &key (:star :ignore)) :lisp2) +(define-caller-pattern define-declaration + (name + lambda-list + (:star form)) + :lisp2) +(define-caller-pattern parse-macro (name lambda-list form) :lisp2) +(define-caller-pattern enclose (form &optional :ignore) :lisp2) + + +;;; Declarations +(define-caller-pattern declare ((:rest :ignore)) :lisp) +(define-caller-pattern proclaim ((:rest :ignore)) :lisp) +(define-caller-pattern locally ((:star declaration) (:star form)) :lisp) +(define-caller-pattern declaim ((:rest :ignore)) :lisp2) +(define-caller-pattern the (form form) :lisp) + +;;; Symbols +(define-caller-pattern get (form form (:optional form)) :lisp) +(define-caller-pattern remprop (form form) :lisp) +(define-caller-pattern symbol-plist (form) :lisp) +(define-caller-pattern getf (form form (:optional form)) :lisp) +(define-caller-pattern remf (form form) :lisp) +(define-caller-pattern get-properties (form form) :lisp) + +(define-caller-pattern symbol-name (form) :lisp) +(define-caller-pattern make-symbol (form) :lisp) +(define-caller-pattern copy-symbol (form (:optional :ignore)) :lisp) +(define-caller-pattern gensym ((:optional :ignore)) :lisp) +(define-variable-pattern *gensym-counter* :lisp2) +(define-caller-pattern gentemp ((:optional :ignore :ignore)) :lisp) +(define-caller-pattern symbol-package (form) :lisp) +(define-caller-pattern keywordp (form) :lisp) + +;;; Packages +(define-variable-pattern *package* :lisp) +(define-caller-pattern make-package ((:rest :ignore)) :lisp) +(define-caller-pattern in-package ((:rest :ignore)) :lisp) +(define-caller-pattern find-package ((:rest :ignore)) :lisp) +(define-caller-pattern package-name ((:rest :ignore)) :lisp) +(define-caller-pattern package-nicknames ((:rest :ignore)) :lisp) +(define-caller-pattern rename-package ((:rest :ignore)) :lisp) +(define-caller-pattern package-use-list ((:rest :ignore)) :lisp) +(define-caller-pattern package-used-by-list ((:rest :ignore)) :lisp) +(define-caller-pattern package-shadowing-symbols ((:rest :ignore)) :lisp) +(define-caller-pattern list-all-packages () :lisp) +(define-caller-pattern delete-package ((:rest :ignore)) :lisp2) +(define-caller-pattern intern (form &optional :ignore) :lisp) +(define-caller-pattern find-symbol (form &optional :ignore) :lisp) +(define-caller-pattern unintern (form &optional :ignore) :lisp) + +(define-caller-pattern export ((:or symbol ((:star symbol))) + &optional :ignore) :lisp) +(define-caller-pattern unexport ((:or symbol ((:star symbol))) + &optional :ignore) :lisp) +(define-caller-pattern import ((:or symbol ((:star symbol))) + &optional :ignore) :lisp) +(define-caller-pattern shadowing-import ((:or symbol ((:star symbol))) + &optional :ignore) :lisp) +(define-caller-pattern shadow ((:or symbol ((:star symbol))) + &optional :ignore) :lisp) + +(define-caller-pattern use-package ((:rest :ignore)) :lisp) +(define-caller-pattern unuse-package ((:rest :ignore)) :lisp) +(define-caller-pattern defpackage (name (:rest :ignore)) :lisp2) +(define-caller-pattern find-all-symbols (form) :lisp) +(define-caller-pattern do-symbols + ((var (:optional form (:optional form))) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern do-external-symbols + ((var (:optional form (:optional form))) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern do-all-symbols + ((var (:optional form)) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern with-package-iterator + ((name form (:plus :ignore)) + (:star form)) + :lisp2) + +;;; Modules +(define-variable-pattern *modules* :lisp) +(define-caller-pattern provide (form) :lisp) +(define-caller-pattern require (form &optional :ignore) :lisp) + + +;;; Numbers +(define-caller-pattern zerop (form) :lisp) +(define-caller-pattern plusp (form) :lisp) +(define-caller-pattern minusp (form) :lisp) +(define-caller-pattern oddp (form) :lisp) +(define-caller-pattern evenp (form) :lisp) + +(define-caller-pattern = (form (:star form)) :lisp) +(define-caller-pattern /= (form (:star form)) :lisp) +(define-caller-pattern > (form (:star form)) :lisp) +(define-caller-pattern < (form (:star form)) :lisp) +(define-caller-pattern <= (form (:star form)) :lisp) +(define-caller-pattern >= (form (:star form)) :lisp) + +(define-caller-pattern max (form (:star form)) :lisp) +(define-caller-pattern min (form (:star form)) :lisp) + +(define-caller-pattern - (form (:star form)) :lisp) +(define-caller-pattern + (form (:star form)) :lisp) +(define-caller-pattern * (form (:star form)) :lisp) +(define-caller-pattern / (form (:star form)) :lisp) +(define-caller-pattern 1+ (form) :lisp) +(define-caller-pattern 1- (form) :lisp) + +(define-caller-pattern incf (form form) :lisp) +(define-caller-pattern decf (form form) :lisp) + +(define-caller-pattern conjugate (form) :lisp) + +(define-caller-pattern gcd ((:star form)) :lisp) +(define-caller-pattern lcm ((:star form)) :lisp) + +(define-caller-pattern exp (form) :lisp) +(define-caller-pattern expt (form form) :lisp) +(define-caller-pattern log (form (:optional form)) :lisp) +(define-caller-pattern sqrt (form) :lisp) +(define-caller-pattern isqrt (form) :lisp) + +(define-caller-pattern abs (form) :lisp) +(define-caller-pattern phase (form) :lisp) +(define-caller-pattern signum (form) :lisp) +(define-caller-pattern sin (form) :lisp) +(define-caller-pattern cos (form) :lisp) +(define-caller-pattern tan (form) :lisp) +(define-caller-pattern cis (form) :lisp) +(define-caller-pattern asin (form) :lisp) +(define-caller-pattern acos (form) :lisp) +(define-caller-pattern atan (form &optional form) :lisp) +(define-variable-pattern pi :lisp) + +(define-caller-pattern sinh (form) :lisp) +(define-caller-pattern cosh (form) :lisp) +(define-caller-pattern tanh (form) :lisp) +(define-caller-pattern asinh (form) :lisp) +(define-caller-pattern acosh (form) :lisp) +(define-caller-pattern atanh (form) :lisp) + +;;; Type Conversions and Extractions +(define-caller-pattern float (form (:optional form)) :lisp) +(define-caller-pattern rational (form) :lisp) +(define-caller-pattern rationalize (form) :lisp) +(define-caller-pattern numerator (form) :lisp) +(define-caller-pattern denominator (form) :lisp) + +(define-caller-pattern floor (form (:optional form)) :lisp) +(define-caller-pattern ceiling (form (:optional form)) :lisp) +(define-caller-pattern truncate (form (:optional form)) :lisp) +(define-caller-pattern round (form (:optional form)) :lisp) + +(define-caller-pattern mod (form form) :lisp) +(define-caller-pattern rem (form form) :lisp) + +(define-caller-pattern ffloor (form (:optional form)) :lisp) +(define-caller-pattern fceiling (form (:optional form)) :lisp) +(define-caller-pattern ftruncate (form (:optional form)) :lisp) +(define-caller-pattern fround (form (:optional form)) :lisp) + +(define-caller-pattern decode-float (form) :lisp) +(define-caller-pattern scale-float (form form) :lisp) +(define-caller-pattern float-radix (form) :lisp) +(define-caller-pattern float-sign (form (:optional form)) :lisp) +(define-caller-pattern float-digits (form) :lisp) +(define-caller-pattern float-precision (form) :lisp) +(define-caller-pattern integer-decode-float (form) :lisp) + +(define-caller-pattern complex (form (:optional form)) :lisp) +(define-caller-pattern realpart (form) :lisp) +(define-caller-pattern imagpart (form) :lisp) + +(define-caller-pattern logior ((:star form)) :lisp) +(define-caller-pattern logxor ((:star form)) :lisp) +(define-caller-pattern logand ((:star form)) :lisp) +(define-caller-pattern logeqv ((:star form)) :lisp) + +(define-caller-pattern lognand (form form) :lisp) +(define-caller-pattern lognor (form form) :lisp) +(define-caller-pattern logandc1 (form form) :lisp) +(define-caller-pattern logandc2 (form form) :lisp) +(define-caller-pattern logorc1 (form form) :lisp) +(define-caller-pattern logorc2 (form form) :lisp) + +(define-caller-pattern boole (form form form) :lisp) +(define-variable-pattern boole-clr :lisp) +(define-variable-pattern boole-set :lisp) +(define-variable-pattern boole-1 :lisp) +(define-variable-pattern boole-2 :lisp) +(define-variable-pattern boole-c1 :lisp) +(define-variable-pattern boole-c2 :lisp) +(define-variable-pattern boole-and :lisp) +(define-variable-pattern boole-ior :lisp) +(define-variable-pattern boole-xor :lisp) +(define-variable-pattern boole-eqv :lisp) +(define-variable-pattern boole-nand :lisp) +(define-variable-pattern boole-nor :lisp) +(define-variable-pattern boole-andc1 :lisp) +(define-variable-pattern boole-andc2 :lisp) +(define-variable-pattern boole-orc1 :lisp) +(define-variable-pattern boole-orc2 :lisp) + +(define-caller-pattern lognot (form) :lisp) +(define-caller-pattern logtest (form form) :lisp) +(define-caller-pattern logbitp (form form) :lisp) +(define-caller-pattern ash (form form) :lisp) +(define-caller-pattern logcount (form) :lisp) +(define-caller-pattern integer-length (form) :lisp) + +(define-caller-pattern byte (form form) :lisp) +(define-caller-pattern byte-size (form) :lisp) +(define-caller-pattern byte-position (form) :lisp) +(define-caller-pattern ldb (form form) :lisp) +(define-caller-pattern ldb-test (form form) :lisp) +(define-caller-pattern mask-field (form form) :lisp) +(define-caller-pattern dpb (form form form) :lisp) +(define-caller-pattern deposit-field (form form form) :lisp) + +;;; Random Numbers +(define-caller-pattern random (form (:optional form)) :lisp) +(define-variable-pattern *random-state* :lisp) +(define-caller-pattern make-random-state ((:optional form)) :lisp) +(define-caller-pattern random-state-p (form) :lisp) + +;;; Implementation Parameters +(define-variable-pattern most-positive-fixnum :lisp) +(define-variable-pattern most-negative-fixnum :lisp) +(define-variable-pattern most-positive-short-float :lisp) +(define-variable-pattern least-positive-short-float :lisp) +(define-variable-pattern least-negative-short-float :lisp) +(define-variable-pattern most-negative-short-float :lisp) +(define-variable-pattern most-positive-single-float :lisp) +(define-variable-pattern least-positive-single-float :lisp) +(define-variable-pattern least-negative-single-float :lisp) +(define-variable-pattern most-negative-single-float :lisp) +(define-variable-pattern most-positive-double-float :lisp) +(define-variable-pattern least-positive-double-float :lisp) +(define-variable-pattern least-negative-double-float :lisp) +(define-variable-pattern most-negative-double-float :lisp) +(define-variable-pattern most-positive-long-float :lisp) +(define-variable-pattern least-positive-long-float :lisp) +(define-variable-pattern least-negative-long-float :lisp) +(define-variable-pattern most-negative-long-float :lisp) +(define-variable-pattern least-positive-normalized-short-float :lisp2) +(define-variable-pattern least-negative-normalized-short-float :lisp2) +(define-variable-pattern least-positive-normalized-single-float :lisp2) +(define-variable-pattern least-negative-normalized-single-float :lisp2) +(define-variable-pattern least-positive-normalized-double-float :lisp2) +(define-variable-pattern least-negative-normalized-double-float :lisp2) +(define-variable-pattern least-positive-normalized-long-float :lisp2) +(define-variable-pattern least-negative-normalized-long-float :lisp2) +(define-variable-pattern short-float-epsilon :lisp) +(define-variable-pattern single-float-epsilon :lisp) +(define-variable-pattern double-float-epsilon :lisp) +(define-variable-pattern long-float-epsilon :lisp) +(define-variable-pattern short-float-negative-epsilon :lisp) +(define-variable-pattern single-float-negative-epsilon :lisp) +(define-variable-pattern double-float-negative-epsilon :lisp) +(define-variable-pattern long-float-negative-epsilon :lisp) + +;;; Characters +(define-variable-pattern char-code-limit :lisp) +(define-variable-pattern char-font-limit :lisp) +(define-variable-pattern char-bits-limit :lisp) +(define-caller-pattern standard-char-p (form) :lisp) +(define-caller-pattern graphic-char-p (form) :lisp) +(define-caller-pattern string-char-p (form) :lisp) +(define-caller-pattern alpha-char-p (form) :lisp) +(define-caller-pattern upper-case-p (form) :lisp) +(define-caller-pattern lower-case-p (form) :lisp) +(define-caller-pattern both-case-p (form) :lisp) +(define-caller-pattern digit-char-p (form (:optional form)) :lisp) +(define-caller-pattern alphanumericp (form) :lisp) + +(define-caller-pattern char= ((:star form)) :lisp) +(define-caller-pattern char/= ((:star form)) :lisp) +(define-caller-pattern char< ((:star form)) :lisp) +(define-caller-pattern char> ((:star form)) :lisp) +(define-caller-pattern char<= ((:star form)) :lisp) +(define-caller-pattern char>= ((:star form)) :lisp) + +(define-caller-pattern char-equal ((:star form)) :lisp) +(define-caller-pattern char-not-equal ((:star form)) :lisp) +(define-caller-pattern char-lessp ((:star form)) :lisp) +(define-caller-pattern char-greaterp ((:star form)) :lisp) +(define-caller-pattern char-not-greaterp ((:star form)) :lisp) +(define-caller-pattern char-not-lessp ((:star form)) :lisp) + +(define-caller-pattern char-code (form) :lisp) +(define-caller-pattern char-bits (form) :lisp) +(define-caller-pattern char-font (form) :lisp) +(define-caller-pattern code-char (form (:optional form form)) :lisp) +(define-caller-pattern make-char (form (:optional form form)) :lisp) +(define-caller-pattern characterp (form) :lisp) +(define-caller-pattern char-upcase (form) :lisp) +(define-caller-pattern char-downcase (form) :lisp) +(define-caller-pattern digit-char (form (:optional form form)) :lisp) +(define-caller-pattern char-int (form) :lisp) +(define-caller-pattern int-char (form) :lisp) +(define-caller-pattern char-name (form) :lisp) +(define-caller-pattern name-char (form) :lisp) +(define-variable-pattern char-control-bit :lisp) +(define-variable-pattern char-meta-bit :lisp) +(define-variable-pattern char-super-bit :lisp) +(define-variable-pattern char-hyper-bit :lisp) +(define-caller-pattern char-bit (form form) :lisp) +(define-caller-pattern set-char-bit (form form form) :lisp) + +;;; Sequences +(define-caller-pattern complement (fn) :lisp2) +(define-caller-pattern elt (form form) :lisp) +(define-caller-pattern subseq (form form &optional form) :lisp) +(define-caller-pattern copy-seq (form) :lisp) +(define-caller-pattern length (form) :lisp) +(define-caller-pattern reverse (form) :lisp) +(define-caller-pattern nreverse (form) :lisp) +(define-caller-pattern make-sequence (form form &key form) :lisp) + +(define-caller-pattern concatenate (form (:star form)) :lisp) +(define-caller-pattern map (form fn form (:star form)) :lisp) +(define-caller-pattern map-into (form fn (:star form)) :lisp2) + +(define-caller-pattern some (fn form (:star form)) :lisp) +(define-caller-pattern every (fn form (:star form)) :lisp) +(define-caller-pattern notany (fn form (:star form)) :lisp) +(define-caller-pattern notevery (fn form (:star form)) :lisp) + +(define-caller-pattern reduce (fn form &key (:star form)) :lisp) +(define-caller-pattern fill (form form &key (:star form)) :lisp) +(define-caller-pattern replace (form form &key (:star form)) :lisp) +(define-caller-pattern remove (form form &key (:star form)) :lisp) +(define-caller-pattern remove-if (fn form &key (:star form)) :lisp) +(define-caller-pattern remove-if-not (fn form &key (:star form)) :lisp) +(define-caller-pattern delete (form form &key (:star form)) :lisp) +(define-caller-pattern delete-if (fn form &key (:star form)) :lisp) +(define-caller-pattern delete-if-not (fn form &key (:star form)) :lisp) +(define-caller-pattern remove-duplicates (form &key (:star form)) :lisp) +(define-caller-pattern delete-duplicates (form &key (:star form)) :lisp) +(define-caller-pattern substitute (form form form &key (:star form)) :lisp) +(define-caller-pattern substitute-if (form fn form &key (:star form)) :lisp) +(define-caller-pattern substitute-if-not (form fn form &key (:star form)) + :lisp) +(define-caller-pattern nsubstitute (form form form &key (:star form)) :lisp) +(define-caller-pattern nsubstitute-if (form fn form &key (:star form)) :lisp) +(define-caller-pattern nsubstitute-if-not (form fn form &key (:star form)) + :lisp) +(define-caller-pattern find (form form &key (:star form)) :lisp) +(define-caller-pattern find-if (fn form &key (:star form)) :lisp) +(define-caller-pattern find-if-not (fn form &key (:star form)) :lisp) +(define-caller-pattern position (form form &key (:star form)) :lisp) +(define-caller-pattern position-if (fn form &key (:star form)) :lisp) +(define-caller-pattern position-if-not (fn form &key (:star form)) :lisp) +(define-caller-pattern count (form form &key (:star form)) :lisp) +(define-caller-pattern count-if (fn form &key (:star form)) :lisp) +(define-caller-pattern count-if-not (fn form &key (:star form)) :lisp) +(define-caller-pattern mismatch (form form &key (:star form)) :lisp) +(define-caller-pattern search (form form &key (:star form)) :lisp) +(define-caller-pattern sort (form fn &key (:star form)) :lisp) +(define-caller-pattern stable-sort (form fn &key (:star form)) :lisp) +(define-caller-pattern merge (form form form fn &key (:star form)) :lisp) + +;;; Lists +(define-caller-pattern car (form) :lisp) +(define-caller-pattern cdr (form) :lisp) +(define-caller-pattern caar (form) :lisp) +(define-caller-pattern cadr (form) :lisp) +(define-caller-pattern cdar (form) :lisp) +(define-caller-pattern cddr (form) :lisp) +(define-caller-pattern caaar (form) :lisp) +(define-caller-pattern caadr (form) :lisp) +(define-caller-pattern cadar (form) :lisp) +(define-caller-pattern caddr (form) :lisp) +(define-caller-pattern cdaar (form) :lisp) +(define-caller-pattern cdadr (form) :lisp) +(define-caller-pattern cddar (form) :lisp) +(define-caller-pattern cdddr (form) :lisp) +(define-caller-pattern caaaar (form) :lisp) +(define-caller-pattern caaadr (form) :lisp) +(define-caller-pattern caadar (form) :lisp) +(define-caller-pattern caaddr (form) :lisp) +(define-caller-pattern cadaar (form) :lisp) +(define-caller-pattern cadadr (form) :lisp) +(define-caller-pattern caddar (form) :lisp) +(define-caller-pattern cadddr (form) :lisp) +(define-caller-pattern cdaaar (form) :lisp) +(define-caller-pattern cdaadr (form) :lisp) +(define-caller-pattern cdadar (form) :lisp) +(define-caller-pattern cdaddr (form) :lisp) +(define-caller-pattern cddaar (form) :lisp) +(define-caller-pattern cddadr (form) :lisp) +(define-caller-pattern cdddar (form) :lisp) +(define-caller-pattern cddddr (form) :lisp) + +(define-caller-pattern cons (form form) :lisp) +(define-caller-pattern tree-equal (form form &key (:star fn)) :lisp) +(define-caller-pattern endp (form) :lisp) +(define-caller-pattern list-length (form) :lisp) +(define-caller-pattern nth (form form) :lisp) + +(define-caller-pattern first (form) :lisp) +(define-caller-pattern second (form) :lisp) +(define-caller-pattern third (form) :lisp) +(define-caller-pattern fourth (form) :lisp) +(define-caller-pattern fifth (form) :lisp) +(define-caller-pattern sixth (form) :lisp) +(define-caller-pattern seventh (form) :lisp) +(define-caller-pattern eighth (form) :lisp) +(define-caller-pattern ninth (form) :lisp) +(define-caller-pattern tenth (form) :lisp) + +(define-caller-pattern rest (form) :lisp) +(define-caller-pattern nthcdr (form form) :lisp) +(define-caller-pattern last (form (:optional form)) :lisp) +(define-caller-pattern list ((:star form)) :lisp) +(define-caller-pattern list* ((:star form)) :lisp) +(define-caller-pattern make-list (form &key (:star form)) :lisp) +(define-caller-pattern append ((:star form)) :lisp) +(define-caller-pattern copy-list (form) :lisp) +(define-caller-pattern copy-alist (form) :lisp) +(define-caller-pattern copy-tree (form) :lisp) +(define-caller-pattern revappend (form form) :lisp) +(define-caller-pattern nconc ((:star form)) :lisp) +(define-caller-pattern nreconc (form form) :lisp) +(define-caller-pattern push (form form) :lisp) +(define-caller-pattern pushnew (form form &key (:star form)) :lisp) +(define-caller-pattern pop (form) :lisp) +(define-caller-pattern butlast (form (:optional form)) :lisp) +(define-caller-pattern nbutlast (form (:optional form)) :lisp) +(define-caller-pattern ldiff (form form) :lisp) +(define-caller-pattern rplaca (form form) :lisp) +(define-caller-pattern rplacd (form form) :lisp) + +(define-caller-pattern subst (form form form &key (:star form)) :lisp) +(define-caller-pattern subst-if (form fn form &key (:star form)) :lisp) +(define-caller-pattern subst-if-not (form fn form &key (:star form)) :lisp) +(define-caller-pattern nsubst (form form form &key (:star form)) :lisp) +(define-caller-pattern nsubst-if (form fn form &key (:star form)) :lisp) +(define-caller-pattern nsubst-if-not (form fn form &key (:star form)) :lisp) +(define-caller-pattern sublis (form form &key (:star form)) :lisp) +(define-caller-pattern nsublis (form form &key (:star form)) :lisp) +(define-caller-pattern member (form form &key (:star form)) :lisp) +(define-caller-pattern member-if (fn form &key (:star form)) :lisp) +(define-caller-pattern member-if-not (fn form &key (:star form)) :lisp) + +(define-caller-pattern tailp (form form) :lisp) +(define-caller-pattern adjoin (form form &key (:star form)) :lisp) +(define-caller-pattern union (form form &key (:star form)) :lisp) +(define-caller-pattern nunion (form form &key (:star form)) :lisp) +(define-caller-pattern intersection (form form &key (:star form)) :lisp) +(define-caller-pattern nintersection (form form &key (:star form)) :lisp) +(define-caller-pattern set-difference (form form &key (:star form)) :lisp) +(define-caller-pattern nset-difference (form form &key (:star form)) :lisp) +(define-caller-pattern set-exclusive-or (form form &key (:star form)) :lisp) +(define-caller-pattern nset-exclusive-or (form form &key (:star form)) :lisp) +(define-caller-pattern subsetp (form form &key (:star form)) :lisp) + +(define-caller-pattern acons (form form form) :lisp) +(define-caller-pattern pairlis (form form (:optional form)) :lisp) +(define-caller-pattern assoc (form form &key (:star form)) :lisp) +(define-caller-pattern assoc-if (fn form) :lisp) +(define-caller-pattern assoc-if-not (fn form) :lisp) +(define-caller-pattern rassoc (form form &key (:star form)) :lisp) +(define-caller-pattern rassoc-if (fn form &key (:star form)) :lisp) +(define-caller-pattern rassoc-if-not (fn form &key (:star form)) :lisp) + +;;; Hash Tables +(define-caller-pattern make-hash-table (&key (:star form)) :lisp) +(define-caller-pattern hash-table-p (form) :lisp) +(define-caller-pattern gethash (form form (:optional form)) :lisp) +(define-caller-pattern remhash (form form) :lisp) +(define-caller-pattern maphash (fn form) :lisp) +(define-caller-pattern clrhash (form) :lisp) +(define-caller-pattern hash-table-count (form) :lisp) +(define-caller-pattern with-hash-table-iterator + ((name form) (:star form)) :lisp2) +(define-caller-pattern hash-table-rehash-size (form) :lisp2) +(define-caller-pattern hash-table-rehash-threshold (form) :lisp2) +(define-caller-pattern hash-table-size (form) :lisp2) +(define-caller-pattern hash-table-test (form) :lisp2) +(define-caller-pattern sxhash (form) :lisp) + +;;; Arrays +(define-caller-pattern make-array (form &key (:star form)) :lisp) +(define-variable-pattern array-rank-limit :lisp) +(define-variable-pattern array-dimension-limit :lisp) +(define-variable-pattern array-total-size-limit :lisp) +(define-caller-pattern vector ((:star form)) :lisp) +(define-caller-pattern aref (form (:star form)) :lisp) +(define-caller-pattern svref (form form) :lisp) +(define-caller-pattern array-element-type (form) :lisp) +(define-caller-pattern array-rank (form) :lisp) +(define-caller-pattern array-dimension (form form) :lisp) +(define-caller-pattern array-dimensions (form) :lisp) +(define-caller-pattern array-total-size (form) :lisp) +(define-caller-pattern array-in-bounds-p (form (:star form)) :lisp) +(define-caller-pattern array-row-major-index (form (:star form)) :lisp) +(define-caller-pattern row-major-aref (form form) :lisp2) +(define-caller-pattern adjustable-array-p (form) :lisp) + +(define-caller-pattern bit (form (:star form)) :lisp) +(define-caller-pattern sbit (form (:star form)) :lisp) + +(define-caller-pattern bit-and (form form (:optional form)) :lisp) +(define-caller-pattern bit-ior (form form (:optional form)) :lisp) +(define-caller-pattern bit-xor (form form (:optional form)) :lisp) +(define-caller-pattern bit-eqv (form form (:optional form)) :lisp) +(define-caller-pattern bit-nand (form form (:optional form)) :lisp) +(define-caller-pattern bit-nor (form form (:optional form)) :lisp) +(define-caller-pattern bit-andc1 (form form (:optional form)) :lisp) +(define-caller-pattern bit-andc2 (form form (:optional form)) :lisp) +(define-caller-pattern bit-orc1 (form form (:optional form)) :lisp) +(define-caller-pattern bit-orc2 (form form (:optional form)) :lisp) +(define-caller-pattern bit-not (form (:optional form)) :lisp) + +(define-caller-pattern array-has-fill-pointer-p (form) :lisp) +(define-caller-pattern fill-pointer (form) :lisp) +(define-caller-pattern vector-push (form form) :lisp) +(define-caller-pattern vector-push-extend (form form (:optional form)) :lisp) +(define-caller-pattern vector-pop (form) :lisp) +(define-caller-pattern adjust-array (form form &key (:star form)) :lisp) + +;;; Strings +(define-caller-pattern char (form form) :lisp) +(define-caller-pattern schar (form form) :lisp) +(define-caller-pattern string= (form form &key (:star form)) :lisp) +(define-caller-pattern string-equal (form form &key (:star form)) :lisp) +(define-caller-pattern string< (form form &key (:star form)) :lisp) +(define-caller-pattern string> (form form &key (:star form)) :lisp) +(define-caller-pattern string<= (form form &key (:star form)) :lisp) +(define-caller-pattern string>= (form form &key (:star form)) :lisp) +(define-caller-pattern string/= (form form &key (:star form)) :lisp) +(define-caller-pattern string-lessp (form form &key (:star form)) :lisp) +(define-caller-pattern string-greaterp (form form &key (:star form)) :lisp) +(define-caller-pattern string-not-greaterp (form form &key (:star form)) :lisp) +(define-caller-pattern string-not-lessp (form form &key (:star form)) :lisp) +(define-caller-pattern string-not-equal (form form &key (:star form)) :lisp) + +(define-caller-pattern make-string (form &key (:star form)) :lisp) +(define-caller-pattern string-trim (form form) :lisp) +(define-caller-pattern string-left-trim (form form) :lisp) +(define-caller-pattern string-right-trim (form form) :lisp) +(define-caller-pattern string-upcase (form &key (:star form)) :lisp) +(define-caller-pattern string-downcase (form &key (:star form)) :lisp) +(define-caller-pattern string-capitalize (form &key (:star form)) :lisp) +(define-caller-pattern nstring-upcase (form &key (:star form)) :lisp) +(define-caller-pattern nstring-downcase (form &key (:star form)) :lisp) +(define-caller-pattern nstring-capitalize (form &key (:star form)) :lisp) +(define-caller-pattern string (form) :lisp) + +;;; Structures +(define-caller-pattern defstruct + ((:or name (name (:rest :ignore))) + (:optional documentation-string) + (:plus :ignore)) + :lisp) + +;;; The Evaluator +(define-caller-pattern eval (form) :lisp) +(define-variable-pattern *evalhook* :lisp) +(define-variable-pattern *applyhook* :lisp) +(define-caller-pattern evalhook (form fn fn &optional :ignore) :lisp) +(define-caller-pattern applyhook (fn form fn fn &optional :ignore) :lisp) +(define-caller-pattern constantp (form) :lisp) + +;;; Streams +(define-variable-pattern *standard-input* :lisp) +(define-variable-pattern *standard-output* :lisp) +(define-variable-pattern *error-output* :lisp) +(define-variable-pattern *query-io* :lisp) +(define-variable-pattern *debug-io* :lisp) +(define-variable-pattern *terminal-io* :lisp) +(define-variable-pattern *trace-output* :lisp) +(define-caller-pattern make-synonym-stream (symbol) :lisp) +(define-caller-pattern make-broadcast-stream ((:star form)) :lisp) +(define-caller-pattern make-concatenated-stream ((:star form)) :lisp) +(define-caller-pattern make-two-way-stream (form form) :lisp) +(define-caller-pattern make-echo-stream (form form) :lisp) +(define-caller-pattern make-string-input-stream (form &optional form form) + :lisp) +(define-caller-pattern make-string-output-stream (&key (:star form)) :lisp) +(define-caller-pattern get-output-stream-string (form) :lisp) + +(define-caller-pattern with-open-stream + ((var form) + (:star declaration) + (:star form)) + :lisp) + +(define-caller-pattern with-input-from-string + ((var form &key (:star form)) + (:star declaration) + (:star form)) + :lisp) + +(define-caller-pattern with-output-to-string + ((var (:optional form)) + (:star declaration) + (:star form)) + :lisp) +(define-caller-pattern streamp (form) :lisp) +(define-caller-pattern open-stream-p (form) :lisp2) +(define-caller-pattern input-stream-p (form) :lisp) +(define-caller-pattern output-stream-p (form) :lisp) +(define-caller-pattern stream-element-type (form) :lisp) +(define-caller-pattern close (form (:rest :ignore)) :lisp) +(define-caller-pattern broadcast-stream-streams (form) :lisp2) +(define-caller-pattern concatenated-stream-streams (form) :lisp2) +(define-caller-pattern echo-stream-input-stream (form) :lisp2) +(define-caller-pattern echo-stream-output-stream (form) :lisp2) +(define-caller-pattern synonym-stream-symbol (form) :lisp2) +(define-caller-pattern two-way-stream-input-stream (form) :lisp2) +(define-caller-pattern two-way-stream-output-stream (form) :lisp2) +(define-caller-pattern interactive-stream-p (form) :lisp2) +(define-caller-pattern stream-external-format (form) :lisp2) + +;;; Reader +(define-variable-pattern *read-base* :lisp) +(define-variable-pattern *read-suppress* :lisp) +(define-variable-pattern *read-eval* :lisp2) +(define-variable-pattern *readtable* :lisp) +(define-caller-pattern copy-readtable (&optional form form) :lisp) +(define-caller-pattern readtablep (form) :lisp) +(define-caller-pattern set-syntax-from-char (form form &optional form form) + :lisp) +(define-caller-pattern set-macro-character (form fn &optional form) :lisp) +(define-caller-pattern get-macro-character (form (:optional form)) :lisp) +(define-caller-pattern make-dispatch-macro-character (form &optional form form) + :lisp) +(define-caller-pattern set-dispatch-macro-character + (form form fn (:optional form)) :lisp) +(define-caller-pattern get-dispatch-macro-character + (form form (:optional form)) :lisp) +(define-caller-pattern readtable-case (form) :lisp2) +(define-variable-pattern *print-readably* :lisp2) +(define-variable-pattern *print-escape* :lisp) +(define-variable-pattern *print-pretty* :lisp) +(define-variable-pattern *print-circle* :lisp) +(define-variable-pattern *print-base* :lisp) +(define-variable-pattern *print-radix* :lisp) +(define-variable-pattern *print-case* :lisp) +(define-variable-pattern *print-gensym* :lisp) +(define-variable-pattern *print-level* :lisp) +(define-variable-pattern *print-length* :lisp) +(define-variable-pattern *print-array* :lisp) +(define-caller-pattern with-standard-io-syntax + ((:star declaration) + (:star form)) + :lisp2) + +(define-caller-pattern read (&optional form form form form) :lisp) +(define-variable-pattern *read-default-float-format* :lisp) +(define-caller-pattern read-preserving-whitespace + (&optional form form form form) :lisp) +(define-caller-pattern read-delimited-list (form &optional form form) :lisp) +(define-caller-pattern read-line (&optional form form form form) :lisp) +(define-caller-pattern read-char (&optional form form form form) :lisp) +(define-caller-pattern unread-char (form (:optional form)) :lisp) +(define-caller-pattern peek-char (&optional form form form form) :lisp) +(define-caller-pattern listen ((:optional form)) :lisp) +(define-caller-pattern read-char-no-hang ((:star form)) :lisp) +(define-caller-pattern clear-input ((:optional form)) :lisp) +(define-caller-pattern read-from-string (form (:star form)) :lisp) +(define-caller-pattern parse-integer (form &rest :ignore) :lisp) +(define-caller-pattern read-byte ((:star form)) :lisp) + +(define-caller-pattern write (form &key (:star form)) :lisp) +(define-caller-pattern prin1 (form (:optional form)) :lisp) +(define-caller-pattern print (form (:optional form)) :lisp) +(define-caller-pattern pprint (form (:optional form)) :lisp) +(define-caller-pattern princ (form (:optional form)) :lisp) +(define-caller-pattern write-to-string (form &key (:star form)) :lisp) +(define-caller-pattern prin1-to-string (form) :lisp) +(define-caller-pattern princ-to-string (form) :lisp) +(define-caller-pattern write-char (form (:optional form)) :lisp) +(define-caller-pattern write-string (form &optional form &key (:star form)) + :lisp) +(define-caller-pattern write-line (form &optional form &key (:star form)) + :lisp) +(define-caller-pattern terpri ((:optional form)) :lisp) +(define-caller-pattern fresh-line ((:optional form)) :lisp) +(define-caller-pattern finish-output ((:optional form)) :lisp) +(define-caller-pattern force-output ((:optional form)) :lisp) +(define-caller-pattern clear-output ((:optional form)) :lisp) +(define-caller-pattern print-unreadable-object + ((form form &key (:star form)) + (:star declaration) + (:star form)) + :lisp2) +(define-caller-pattern write-byte (form form) :lisp) +(define-caller-pattern format + (destination + control-string + (:rest format-arguments)) + :lisp) + +(define-caller-pattern y-or-n-p (control-string (:star form)) :lisp) +(define-caller-pattern yes-or-no-p (control-string (:star form)) :lisp) + +;;; Pathnames +(define-caller-pattern wild-pathname-p (form &optional form) :lisp2) +(define-caller-pattern pathname-match-p (form form) :lisp2) +(define-caller-pattern translate-pathname (form form form &key (:star form)) + :lisp2) + +(define-caller-pattern logical-pathname (form) :lisp2) +(define-caller-pattern translate-logical-pathname (form &key (:star form)) + :lisp2) +(define-caller-pattern logical-pathname-translations (form) :lisp2) +(define-caller-pattern load-logical-pathname-translations (form) :lisp2) +(define-caller-pattern compile-file-pathname (form &key form) :lisp2) + +(define-caller-pattern pathname (form) :lisp) +(define-caller-pattern truename (form) :lisp) +(define-caller-pattern parse-namestring ((:star form)) :lisp) +(define-caller-pattern merge-pathnames ((:star form)) :lisp) +(define-variable-pattern *default-pathname-defaults* :lisp) +(define-caller-pattern make-pathname ((:star form)) :lisp) +(define-caller-pattern pathnamep (form) :lisp) +(define-caller-pattern pathname-host (form) :lisp) +(define-caller-pattern pathname-device (form) :lisp) +(define-caller-pattern pathname-directory (form) :lisp) +(define-caller-pattern pathname-name (form) :lisp) +(define-caller-pattern pathname-type (form) :lisp) +(define-caller-pattern pathname-version (form) :lisp) +(define-caller-pattern namestring (form) :lisp) +(define-caller-pattern file-namestring (form) :lisp) +(define-caller-pattern directory-namestring (form) :lisp) +(define-caller-pattern host-namestring (form) :lisp) +(define-caller-pattern enough-namestring (form (:optional form)) :lisp) +(define-caller-pattern user-homedir-pathname (&optional form) :lisp) +(define-caller-pattern open (form &key (:star form)) :lisp) +(define-caller-pattern with-open-file + ((var form (:rest :ignore)) + (:star declaration) + (:star form)) + :lisp) + +(define-caller-pattern rename-file (form form) :lisp) +(define-caller-pattern delete-file (form) :lisp) +(define-caller-pattern probe-file (form) :lisp) +(define-caller-pattern file-write-date (form) :lisp) +(define-caller-pattern file-author (form) :lisp) +(define-caller-pattern file-position (form (:optional form)) :lisp) +(define-caller-pattern file-length (form) :lisp) +(define-caller-pattern file-string-length (form form) :lisp2) +(define-caller-pattern load (form &key (:star form)) :lisp) +(define-variable-pattern *load-verbose* :lisp) +(define-variable-pattern *load-print* :lisp2) +(define-variable-pattern *load-pathname* :lisp2) +(define-variable-pattern *load-truename* :lisp2) +(define-caller-pattern make-load-form (form) :lisp2) +(define-caller-pattern make-load-form-saving-slots (form &optional form) + :lisp2) +(define-caller-pattern directory (form &key (:star form)) :lisp) + +;;; Errors +(define-caller-pattern error (form (:star form)) :lisp) +(define-caller-pattern cerror (form form (:star form)) :lisp) +(define-caller-pattern warn (form (:star form)) :lisp) +(define-variable-pattern *break-on-warnings* :lisp) +(define-caller-pattern break (&optional form (:star form)) :lisp) +(define-caller-pattern check-type (form form (:optional form)) :lisp) +(define-caller-pattern assert + (form + (:optional ((:star var)) + (:optional form (:star form)))) + :lisp) +(define-caller-pattern etypecase (form (:star (symbol (:star form)))) :lisp) +(define-caller-pattern ctypecase (form (:star (symbol (:star form)))) :lisp) +(define-caller-pattern ecase + (form + (:star ((:or symbol ((:star symbol))) + (:star form)))) + :lisp) +(define-caller-pattern ccase + (form + (:star ((:or symbol ((:star symbol))) + (:star form)))) + :lisp) + +;;; The Compiler +(define-caller-pattern compile (form (:optional form)) :lisp) +(define-caller-pattern compile-file (form &key (:star form)) :lisp) +(define-variable-pattern *compile-verbose* :lisp2) +(define-variable-pattern *compile-print* :lisp2) +(define-variable-pattern *compile-file-pathname* :lisp2) +(define-variable-pattern *compile-file-truename* :lisp2) +(define-caller-pattern load-time-value (form (:optional form)) :lisp2) +(define-caller-pattern disassemble (form) :lisp) +(define-caller-pattern function-lambda-expression (fn) :lisp2) +(define-caller-pattern with-compilation-unit (((:star :ignore)) (:star form)) + :lisp2) + +;;; Documentation +(define-caller-pattern documentation (form form) :lisp) +(define-caller-pattern trace ((:star form)) :lisp) +(define-caller-pattern untrace ((:star form)) :lisp) +(define-caller-pattern step (form) :lisp) +(define-caller-pattern time (form) :lisp) +(define-caller-pattern describe (form &optional form) :lisp) +(define-caller-pattern describe-object (form &optional form) :lisp2) +(define-caller-pattern inspect (form) :lisp) +(define-caller-pattern room ((:optional form)) :lisp) +(define-caller-pattern ed ((:optional form)) :lisp) +(define-caller-pattern dribble ((:optional form)) :lisp) +(define-caller-pattern apropos (form (:optional form)) :lisp) +(define-caller-pattern apropos-list (form (:optional form)) :lisp) +(define-caller-pattern get-decoded-time () :lisp) +(define-caller-pattern get-universal-time () :lisp) +(define-caller-pattern decode-universal-time (form &optional form) :lisp) +(define-caller-pattern encode-universal-time + (form form form form form form &optional form) :lisp) +(define-caller-pattern get-internal-run-time () :lisp) +(define-caller-pattern get-internal-real-time () :lisp) +(define-caller-pattern sleep (form) :lisp) + +(define-caller-pattern lisp-implementation-type () :lisp) +(define-caller-pattern lisp-implementation-version () :lisp) +(define-caller-pattern machine-type () :lisp) +(define-caller-pattern machine-version () :lisp) +(define-caller-pattern machine-instance () :lisp) +(define-caller-pattern software-type () :lisp) +(define-caller-pattern software-version () :lisp) +(define-caller-pattern short-site-name () :lisp) +(define-caller-pattern long-site-name () :lisp) +(define-variable-pattern *features* :lisp) + +(define-caller-pattern identity (form) :lisp) + +;;; Pretty Printing +(define-variable-pattern *print-pprint-dispatch* :lisp2) +(define-variable-pattern *print-right-margin* :lisp2) +(define-variable-pattern *print-miser-width* :lisp2) +(define-variable-pattern *print-lines* :lisp2) +(define-caller-pattern pprint-newline (form &optional form) :lisp2) +(define-caller-pattern pprint-logical-block + ((var form &key (:star form)) + (:star form)) + :lisp2) +(define-caller-pattern pprint-exit-if-list-exhausted () :lisp2) +(define-caller-pattern pprint-pop () :lisp2) +(define-caller-pattern pprint-indent (form form &optional form) :lisp2) +(define-caller-pattern pprint-tab (form form form &optional form) :lisp2) +(define-caller-pattern pprint-fill (form form &optional form form) :lisp2) +(define-caller-pattern pprint-linear (form form &optional form form) :lisp2) +(define-caller-pattern pprint-tabular (form form &optional form form form) + :lisp2) +(define-caller-pattern formatter (control-string) :lisp2) +(define-caller-pattern copy-pprint-dispatch (&optional form) :lisp2) +(define-caller-pattern pprint-dispatch (form &optional form) :lisp2) +(define-caller-pattern set-pprint-dispatch (form form &optional form form) + :lisp2) + +;;; CLOS +(define-caller-pattern add-method (fn form) :lisp2) +(define-caller-pattern call-method (form form) :lisp2) +(define-caller-pattern call-next-method ((:star form)) :lisp2) +(define-caller-pattern change-class (form form) :lisp2) +(define-caller-pattern class-name (form) :lisp2) +(define-caller-pattern class-of (form) :lisp2) +(define-caller-pattern compute-applicable-methods (fn (:star form)) :lisp2) +(define-caller-pattern defclass (name &rest :ignore) :lisp2) +(define-caller-pattern defgeneric (name lambda-list &rest :ignore) :lisp2) +(define-caller-pattern define-method-combination + (name lambda-list ((:star :ignore)) + (:optional ((:eq :arguments) :ignore)) + (:optional ((:eq :generic-function) :ignore)) + (:star (:or declaration documentation-string)) + (:star form)) + :lisp2) +(define-caller-pattern defmethod + (name (:star symbol) lambda-list + (:star (:or declaration documentation-string)) + (:star form)) + :lisp2) +(define-caller-pattern ensure-generic-function (name &key (:star form)) :lisp2) +(define-caller-pattern find-class (form &optional form form) :lisp2) +(define-caller-pattern find-method (fn &rest :ignore) :lisp2) +(define-caller-pattern function-keywords (&rest :ignore) :lisp2) +(define-caller-pattern generic-flet (((:star (name lambda-list))) (:star form)) + :lisp2) +(define-caller-pattern generic-labels + (((:star (name lambda-list))) (:star form)) + :lisp2) +(define-caller-pattern generic-function (lambda-list) :lisp2) +(define-caller-pattern initialize-instance (form &key (:star form)) :lisp2) +(define-caller-pattern invalid-method-error (fn form (:star form)) :lisp2) +(define-caller-pattern make-instance (fn (:star form)) :lisp2) +(define-caller-pattern make-instances-obsolete (fn) :lisp2) +(define-caller-pattern method-combination-error (form (:star form)) :lisp2) +(define-caller-pattern method-qualifiers (fn) :lisp2) +(define-caller-pattern next-method-p () :lisp2) +(define-caller-pattern no-applicable-method (fn (:star form)) :lisp2) +(define-caller-pattern no-next-method (fn (:star form)) :lisp2) +(define-caller-pattern print-object (form form) :lisp2) +(define-caller-pattern reinitialize-instance (form (:star form)) :lisp2) +(define-caller-pattern remove-method (fn form) :lisp2) +(define-caller-pattern shared-initialize (form form (:star form)) :lisp2) +(define-caller-pattern slot-boundp (form form) :lisp2) +(define-caller-pattern slot-exists-p (form form) :lisp2) +(define-caller-pattern slot-makeunbound (form form) :lisp2) +(define-caller-pattern slot-missing (fn form form form &optional form) :lisp2) +(define-caller-pattern slot-unbound (fn form form) :lisp2) +(define-caller-pattern slot-value (form form) :lisp2) +(define-caller-pattern update-instance-for-different-class + (form form (:star form)) :lisp2) +(define-caller-pattern update-instance-for-redefined-class + (form form (:star form)) :lisp2) +(define-caller-pattern with-accessors + (((:star :ignore)) form + (:star declaration) + (:star form)) + :lisp2) +(define-caller-pattern with-added-methods + ((name lambda-list) form + (:star form)) + :lisp2) +(define-caller-pattern with-slots + (((:star :ignore)) form + (:star declaration) + (:star form)) + :lisp2) + +;;; Conditions +(define-caller-pattern signal (form (:star form)) :lisp2) +(define-variable-pattern *break-on-signals* :lisp2) +(define-caller-pattern handler-case (form (:star (form ((:optional var)) + (:star form)))) + :lisp2) +(define-caller-pattern ignore-errors ((:star form)) :lisp2) +(define-caller-pattern handler-bind (((:star (form form))) + (:star form)) + :lisp2) +(define-caller-pattern define-condition (name &rest :ignore) :lisp2) +(define-caller-pattern make-condition (form &rest :ignore) :lisp2) +(define-caller-pattern with-simple-restart + ((name form (:star form)) (:star form)) :lisp2) +(define-caller-pattern restart-case + (form + (:star (form form (:star form)))) + :lisp2) +(define-caller-pattern restart-bind + (((:star (name fn &key (:star form)))) + (:star form)) + :lisp2) +(define-caller-pattern with-condition-restarts + (form form + (:star declaration) + (:star form)) + :lisp2) +(define-caller-pattern compute-restarts (&optional form) :lisp2) +(define-caller-pattern restart-name (form) :lisp2) +(define-caller-pattern find-restart (form &optional form) :lisp2) +(define-caller-pattern invoke-restart (form (:star form)) :lisp2) +(define-caller-pattern invoke-restart-interactively (form) :lisp2) +(define-caller-pattern abort (&optional form) :lisp2) +(define-caller-pattern continue (&optional form) :lisp2) +(define-caller-pattern muffle-warning (&optional form) :lisp2) +(define-caller-pattern store-value (form &optional form) :lisp2) +(define-caller-pattern use-value (form &optional form) :lisp2) +(define-caller-pattern invoke-debugger (form) :lisp2) +(define-variable-pattern *debugger-hook* :lisp2) +(define-caller-pattern simple-condition-format-string (form) :lisp2) +(define-caller-pattern simple-condition-format-arguments (form) :lisp2) +(define-caller-pattern type-error-datum (form) :lisp2) +(define-caller-pattern type-error-expected-type (form) :lisp2) +(define-caller-pattern package-error-package (form) :lisp2) +(define-caller-pattern stream-error-stream (form) :lisp2) +(define-caller-pattern file-error-pathname (form) :lisp2) +(define-caller-pattern cell-error-name (form) :lisp2) +(define-caller-pattern arithmetic-error-operation (form) :lisp2) +(define-caller-pattern arithmetic-error-operands (form) :lisp2) + +;;; For ZetaLisp Flavors +(define-caller-pattern send (form fn (:star form)) :flavors) |