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/contrib | |
| parent | 4ca8f6608883d230131f8a9e8b6d6c091c516049 (diff) | |
Much maturering of vim configs
Diffstat (limited to 'vim/bundle/slimv/slime/contrib')
27 files changed, 10603 insertions, 0 deletions
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) |