diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index a0c12525a..8da1cc558 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -41,7 +41,6 @@ jobs: sblint lem.asd sblint lib/lisp-syntax/lem-lisp-syntax.asd sblint modes/lisp-mode/lem-lisp-mode.asd - sblint lib/micros/micros.asd if [ $(grep -r --include="*.lisp" 'lem::' | wc -l) -ne 0 ]; then echo 'using `lem::` internal symbols' diff --git a/.gitmodules b/.gitmodules index d679e2a4c..b6bb190cb 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,6 +1,9 @@ [submodule "lib/lsp-utils/specification/language-server-protocol"] path = language-server-protocol url = https://github.com/microsoft/language-server-protocol.git -[submodule "third-party/lem-base16-themes"] - path = third-party/lem-base16-themes +[submodule "submodules/lem-base16-themes"] + path = submodules/lem-base16-themes url = https://github.com/lem-project/lem-base16-themes.git +[submodule "submodules/micros"] + path = submodules/micros + url = https://github.com/lem-project/micros diff --git a/lib/language-server/controller/language-features.lisp b/lib/language-server/controller/language-features.lisp index b31597e56..f40938a5b 100644 --- a/lib/language-server/controller/language-features.lisp +++ b/lib/language-server/controller/language-features.lisp @@ -175,9 +175,7 @@ 'vector)))))))) (defun autodoc (point) - (let* ((raw-form - (let ((lem-lisp-syntax.parse-for-swank-autodoc::*cursor-marker* 'micros::%cursor-marker%)) - (lem-lisp-syntax:parse-for-swank-autodoc point))) + (let* ((raw-form (lem-lisp-syntax:parse-for-autodoc point)) (result (remote-eval-sync *server* `(micros::autodoc-function ',raw-form) (scan-current-package point)))) diff --git a/lib/lisp-syntax/indent.lisp b/lib/lisp-syntax/indent.lisp index d8ac11d98..5dad4713f 100644 --- a/lib/lisp-syntax/indent.lisp +++ b/lib/lisp-syntax/indent.lisp @@ -52,7 +52,7 @@ (defun indentation-update () (do-all-symbols (symbol) (let ((key (string-downcase symbol))) - (alexandria:when-let ((indent (swank::symbol-indentation symbol))) + (alexandria:when-let ((indent (micros::symbol-indentation symbol))) (update-system-indentation key indent (list (package-name (symbol-package symbol)))))))) diff --git a/lib/lisp-syntax/lem-lisp-syntax.asd b/lib/lisp-syntax/lem-lisp-syntax.asd index b4285c789..f61489eae 100644 --- a/lib/lisp-syntax/lem-lisp-syntax.asd +++ b/lib/lisp-syntax/lem-lisp-syntax.asd @@ -1,10 +1,10 @@ (defsystem "lem-lisp-syntax" - :depends-on ("lem-base" "cl-ppcre" "swank" "trivia") + :depends-on ("lem-base" "cl-ppcre" "micros" "trivia") :serial t :components ((:file "indent") (:file "syntax-table") (:file "misc") (:file "enclosing") - (:file "parse-for-swank-autodoc") + (:file "parse-for-autodoc") (:file "defstruct-to-defclass") (:file "lem-lisp-syntax"))) diff --git a/lib/lisp-syntax/lem-lisp-syntax.lisp b/lib/lisp-syntax/lem-lisp-syntax.lisp index 1e38b0b03..bb7f27a5a 100644 --- a/lib/lisp-syntax/lem-lisp-syntax.lisp +++ b/lib/lisp-syntax/lem-lisp-syntax.lisp @@ -5,5 +5,5 @@ :lem-lisp-syntax.syntax-table :lem-lisp-syntax.misc :lem-lisp-syntax.enclosing - :lem-lisp-syntax.parse-for-swank-autodoc + :lem-lisp-syntax.parse-for-autodoc :lem-lisp-syntax.defstruct-to-defclass)) diff --git a/lib/lisp-syntax/parse-for-swank-autodoc.lisp b/lib/lisp-syntax/parse-for-autodoc.lisp similarity index 89% rename from lib/lisp-syntax/parse-for-swank-autodoc.lisp rename to lib/lisp-syntax/parse-for-autodoc.lisp index 880512e86..a11546628 100644 --- a/lib/lisp-syntax/parse-for-swank-autodoc.lisp +++ b/lib/lisp-syntax/parse-for-autodoc.lisp @@ -1,16 +1,16 @@ -(defpackage :lem-lisp-syntax.parse-for-swank-autodoc +(defpackage :lem-lisp-syntax.parse-for-autodoc (:use :cl :lem-base) - (:export :parse-for-swank-autodoc) + (:export :parse-for-autodoc) #+sbcl (:lock t)) -(in-package :lem-lisp-syntax.parse-for-swank-autodoc) +(in-package :lem-lisp-syntax.parse-for-autodoc) -(defvar *cursor-marker* 'swank::%cursor-marker%) +(defvar *cursor-marker* 'micros::%cursor-marker%) (defun parsing-safe-p (point) (not (in-string-or-comment-p point))) -(defun parse-for-swank-autodoc (point &optional (*cursor-marker* *cursor-marker*)) +(defun parse-for-autodoc (point &optional (*cursor-marker* *cursor-marker*)) (and (parsing-safe-p point) (parse-form-upto-toplevel point 10))) diff --git a/lib/micros/.gitignore b/lib/micros/.gitignore deleted file mode 100644 index 9db6a208c..000000000 --- a/lib/micros/.gitignore +++ /dev/null @@ -1,2 +0,0 @@ -.DS_Store -*.fasl diff --git a/lib/micros/LICENSE b/lib/micros/LICENSE deleted file mode 100644 index 93726de5c..000000000 --- a/lib/micros/LICENSE +++ /dev/null @@ -1,21 +0,0 @@ -MIT License - -Copyright (c) 2023 lem-project - -Permission is hereby granted, free of charge, to any person obtaining a copy -of this software and associated documentation files (the "Software"), to deal -in the Software without restriction, including without limitation the rights -to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -copies of the Software, and to permit persons to whom the Software is -furnished to do so, subject to the following conditions: - -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -SOFTWARE. diff --git a/lib/micros/contrib/swank-arglists.lisp b/lib/micros/contrib/swank-arglists.lisp deleted file mode 100644 index 422377dbe..000000000 --- a/lib/micros/contrib/swank-arglists.lisp +++ /dev/null @@ -1,1648 +0,0 @@ -;;; swank-arglists.lisp --- arglist related code ?? -;; -;; Authors: Matthias Koeppe -;; Tobias C. Rittweiler -;; and others -;; -;; License: Public Domain -;; - -(in-package :micros) - -;;;; 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))) - -;; muffle warnings about using accessors prior to the definition of struct -(declaim (notinline keyword-arg.keyword - keyword-arg.arg-name - keyword-arg.default-arg - optional-arg.arg-name - optional-arg.default-arg)) - -(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." - (if (eq arglist :not-available) - :not-available - (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 - (micros/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 - (micros/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) - (micros/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 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 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 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 (micros/mop:class-finalized-p class))) - ;; Try to finalize the class, which can fail if - ;; superclasses are not defined yet - (ignore-errors (micros/mop:finalize-inheritance class))) - class))) - -(defun extra-keywords/slots (class) - (multiple-value-bind (slots allow-other-keys-p) - (if (micros/mop:class-finalized-p class) - (values (micros/mop:class-slots class) nil) - (values (micros/mop:class-direct-slots class) t)) - (let ((slot-init-keywords - (loop for slot in slots append - (mapcar (lambda (initarg) - (make-keyword-arg - initarg - (micros/mop:slot-definition-name slot) - (and (micros/mop:slot-definition-initfunction slot) - (micros/mop:slot-definition-initform slot)))) - (micros/mop:slot-definition-initargs slot))))) - (values slot-init-keywords allow-other-keys-p)))) - -(defun extra-keywords/make-instance (operator 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 (micros/mop:class-prototype class)))) - (multiple-value-bind (shared-initialize-keywords si-aokp) - (ignore-errors - (applicable-methods-keywords - #'shared-initialize - (list (micros/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 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 (micros/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)) - args) - (multiple-value-or (extra-keywords/make-instance operator args) - (call-next-method))) - -(defmethod extra-keywords ((operator (eql 'make-condition)) - args) - (multiple-value-or (extra-keywords/make-instance operator args) - (call-next-method))) - -(defmethod extra-keywords ((operator (eql 'error)) - args) - (multiple-value-or (extra-keywords/make-instance operator args) - (call-next-method))) - -(defmethod extra-keywords ((operator (eql 'signal)) - args) - (multiple-value-or (extra-keywords/make-instance operator args) - (call-next-method))) - -(defmethod extra-keywords ((operator (eql 'warn)) - args) - (multiple-value-or (extra-keywords/make-instance operator args) - (call-next-method))) - -(defmethod extra-keywords ((operator (eql 'cerror)) - args) - (multiple-value-bind (keywords aok determiners) - (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)) - args) - (multiple-value-bind (keywords aok determiners) - (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) - (extra-keywords (car form) (cdr 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)) - (when (equalp (package-name (symbol-package operator)) "closer-mop") - (let ((standard-symbol (or (find-symbol (symbol-name operator) :cl) - (find-symbol (symbol-name operator) :micros/mop)))) - (when standard-symbol - (return-from arglist-dispatch - (arglist-dispatch standard-symbol arguments))))) - - (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) - (let ((lambda-list (micros/mop:generic-function-lambda-list gf))) - (with-available-arglist (arglist) (decode-arglist lambda-list) - (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" LSP-BACKEND::%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. - -(defun call-with-autodoc-error-handler (function print-right-margin) - (handler-bind ((serious-condition - #'(lambda (c) - (unless (debug-on-swank-error) - (let ((*print-right-margin* print-right-margin)) - (return-from call-with-autodoc-error-handler - (format nil "Arglist Error: \"~A\"" c))))))) - (funcall function))) - -(defmacro with-autodoc-error-handler ((&key print-right-margin) &body body) - `(call-with-autodoc-error-handler (lambda () ,@body) - ,print-right-margin)) - -(defun autodoc-function (raw-form &key print-right-margin) - (with-autodoc-error-handler (:print-right-margin print-right-margin) - (with-buffer-syntax () - (multiple-value-bind (form arglist obj-at-cursor form-path) - (find-subform-with-arglist (parse-raw-form raw-form)) - (declare (ignore obj-at-cursor)) - (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))) - (let ((*package* (find-package :cl-user))) - (prin1-to-string - (first form)))))))) - -(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." - (with-autodoc-error-handler (:print-right-margin print-right-margin) - (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 ('\), 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 :micros)) - (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) diff --git a/lib/micros/contrib/swank-asdf.lisp b/lib/micros/contrib/swank-asdf.lisp deleted file mode 100644 index 5389a7cc5..000000000 --- a/lib/micros/contrib/swank-asdf.lisp +++ /dev/null @@ -1,531 +0,0 @@ -;;; swank-asdf.lisp -- ASDF support -;; -;; Authors: Daniel Barlow -;; Marco Baringer -;; Edi Weitz -;; Francois-Rene Rideau -;; and others -;; License: Public Domain -;; - -(in-package :micros) - -(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 micros::*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 micros::*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 (and #+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 - (micros/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 make-operation (x) - #+#.(micros/backend:with-symbol 'make-operation 'asdf) - (asdf:make-operation x) - #-#.(micros/backend:with-symbol 'make-operation 'asdf) - (make-instance x)) - -(defun asdf-component-output-files (component) - (while-collecting (c) - (labels ((f (x) - (typecase x - (asdf:source-file - (map () #'c - (asdf:output-files (make-operation '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 (translate-logical-pathname (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))) - -;;; 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-operation 'asdf:compile-op))) - (with-compilation-hooks () - (asdf:perform op component)) - (when load-p - (asdf:perform (make-operation '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*) diff --git a/lib/micros/contrib/swank-buffer-streams.lisp b/lib/micros/contrib/swank-buffer-streams.lisp deleted file mode 100644 index 3ff0c19fb..000000000 --- a/lib/micros/contrib/swank-buffer-streams.lisp +++ /dev/null @@ -1,37 +0,0 @@ -;;; swank-buffer-streams.lisp --- Streams that output to a buffer -;;; -;;; Authors: Ed Langley -;;; -;;; License: This code has been placed in the Public Domain. All warranties -;;; are disclaimed. - -(in-package :micros) - -(defpackage :micros/contrib/buffer-streams - (:use :cl) - (:import-from :swank - defslimefun - add-hook - encode-message - send-event - find-thread - dcase - current-socket-io - send-to-emacs - current-thread-id - wait-for-event - - *emacs-connection* - *event-hook*) - (:export make-buffer-output-stream)) - -(in-package :micros/contrib/buffer-streams) - -(defun get-temporary-identifier () - (intern (symbol-name (gensym "BUFFER")) - :keyword)) - -(defun make-buffer-output-stream (&optional (target-identifier (get-temporary-identifier))) - (micros:ed-rpc '#:slime-make-buffer-stream-target (current-thread-id) target-identifier) - (values (micros:make-output-stream-for-target *emacs-connection* target-identifier) - target-identifier)) diff --git a/lib/micros/contrib/swank-c-p-c.lisp b/lib/micros/contrib/swank-c-p-c.lisp deleted file mode 100644 index 3f0875786..000000000 --- a/lib/micros/contrib/swank-c-p-c.lisp +++ /dev/null @@ -1,293 +0,0 @@ -;;; swank-c-p-c.lisp -- ILISP style Compound Prefix Completion -;; -;; Author: Luke Gorrie -;; Edi Weitz -;; Matthias Koeppe -;; Tobias C. Rittweiler -;; and others -;; -;; License: Public Domain -;; - - -(in-package :micros) - -(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 | # -;; | | | or *BUFFER-PACKAGE* -;; asdf: [tab] | "" | "asdf" | # -;; | | | -;; asdf:foo [tab] | "foo" | "asdf" | # -;; | | | -;; as:fo [tab] | "fo" | "as" | NIL -;; | | | -;; : [tab] | "" | "" | # -;; | | | -;; :foo [tab] | "foo" | "" | # -;; -(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 #\_)))) diff --git a/lib/micros/contrib/swank-clipboard.lisp b/lib/micros/contrib/swank-clipboard.lisp deleted file mode 100644 index 0d49d4734..000000000 --- a/lib/micros/contrib/swank-clipboard.lisp +++ /dev/null @@ -1,69 +0,0 @@ -;;; swank-clipboard.lisp --- Object clipboard -;; -;; Written by Helmut Eller in 2008. -;; License: Public Domain - -(defpackage :micros/contrib/clipboard - (:use :cl) - (:import-from :micros :defslimefun :with-buffer-syntax :dcase) - (:export :add :delete-entry :entries :entry-to-ref :ref)) - -(in-package :micros/contrib/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) - (micros:inspector-nth-part part)) - ((:sldb frame var) - (micros/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))) diff --git a/lib/micros/contrib/swank-fancy-inspector.lisp b/lib/micros/contrib/swank-fancy-inspector.lisp deleted file mode 100644 index 0f0741919..000000000 --- a/lib/micros/contrib/swank-fancy-inspector.lisp +++ /dev/null @@ -1,1005 +0,0 @@ -;;; swank-fancy-inspector.lisp --- Fancy inspector for CLOS objects -;; -;; Author: Marco Baringer and others -;; License: Public Domain -;; - -(in-package :micros) - -(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 (micros/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 - (micros/mop:eql-specializer - `(eql ,(micros/mop:eql-specializer-object spec))) - #-sbcl - (t - (micros/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)))))) - (micros/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 (micros/mop:generic-function-name - (micros/mop:method-generic-function method))) - (micros/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 'micros/mop:eql-specializer) - (not (typep s2 'micros/mop:eql-specializer))) - ((typep s1 'class) - (flet ((cpl (class) - (and (micros/mop:class-finalized-p class) - (micros/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 (micros/mop:method-specializers meth1) - for s2 in (micros/mop:method-specializers meth2) - do (cond ((specializer< s2 s1) (return nil)) - ((specializer< s1 s2) (return t)))))) - (stable-sort (copy-seq (micros/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 (micros/mop:class-direct-slots class)) - (effective-slots (micros/mop:class-slots class)) - (longest-slot-name-length - (loop for slot :in effective-slots - maximize (length (symbol-name - (micros/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 #'micros/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) - (micros/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 (micros/mop:slot-definition-name effective-slot) - direct-slots - :key #'micros/mop:slot-definition-name) - for slot-name = (inspector-princ - (micros/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 (micros/mop:slot-boundp-using-class class object slot))) - (if boundp - `(:value ,(micros/mop:slot-value-using-class class object slot)) - "#")))) - -(defun slot-home-class-using-class (slot class) - (let ((slot-name (micros/mop:slot-definition-name slot))) - (loop for class in (reverse (micros/mop:class-precedence-list class)) - thereis (and (member slot-name (micros/mop:class-direct-slots class) - :key #'micros/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 (micros/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 (micros/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" (micros/mop:generic-function-name gf)) - (lv "Arguments" (micros/mop:generic-function-lambda-list gf)) - (docstring-ispec "Documentation" gf t) - (lv "Method class" (micros/mop:generic-function-method-class gf)) - (lv "Method combination" - (micros/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 (micros/mop:method-generic-function method) - `("Method defined on the generic function " - (:value ,(micros/mop:method-generic-function method) - ,(inspector-princ - (micros/mop:generic-function-name - (micros/mop:method-generic-function method))))) - '("Method without a generic function")) - (:newline) - ,@(docstring-ispec "Documentation" method t) - "Lambda List: " (:value ,(micros/mop:method-lambda-list method)) - (:newline) - "Specializers: " (:value ,(micros/mop:method-specializers method) - ,(inspector-princ - (method-specializers-for-inspect method))) - (:newline) - "Qualifiers: " (:value ,(micros/mop:method-qualifiers method)) - (:newline) - "Method function: " (:value ,(micros/mop:method-function method)) - (:newline) - ,@(all-slots-for-inspector method))) - -(defun specializer-direct-methods (class) - (sort (copy-seq (micros/mop:specializer-direct-methods class)) - #'string< - :key - (lambda (x) - (symbol-name - (let ((name (micros/mop::generic-function-name - (micros/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 (micros/mop:class-direct-superclasses class)) - (:newline) - "Direct Slots: " - ,@(common-seperated-spec - (micros/mop:class-direct-slots class) - (lambda (slot) - `(:value ,slot ,(inspector-princ - (micros/mop:slot-definition-name slot))))) - (:newline) - "Effective Slots: " - ,@(if (micros/mop:class-finalized-p class) - (common-seperated-spec - (micros/mop:class-slots class) - (lambda (slot) - `(:value ,slot ,(inspector-princ - (micros/mop:slot-definition-name slot))))) - `("# " - (:action "[finalize]" - ,(lambda () (micros/mop:finalize-inheritance class))))) - (:newline) - ,@(let ((doc (documentation class t))) - (when doc - `("Documentation:" (:newline) ,(inspector-princ doc) (:newline)))) - "Sub classes: " - ,@(common-seperated-spec (micros/mop:class-direct-subclasses class) - (lambda (sub) - `(:value ,sub - ,(inspector-princ (class-name sub))))) - (:newline) - "Precedence List: " - ,@(if (micros/mop:class-finalized-p class) - (common-seperated-spec - (micros/mop:class-precedence-list class) - (lambda (class) - `(:value ,class ,(inspector-princ (class-name class))))) - '("#")) - (:newline) - ,@(when (micros/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 (micros/mop:class-finalized-p class) - `(:value ,(micros/mop:class-prototype class)) - '"#") - (:newline) - ,@(all-slots-for-inspector class))) - -(defmethod emacs-inspect ((slot micros/mop:standard-slot-definition)) - `("Name: " - (:value ,(micros/mop:slot-definition-name slot)) - (:newline) - ,@(when (micros/mop:slot-definition-documentation slot) - `("Documentation:" (:newline) - (:value ,(micros/mop:slot-definition-documentation - slot)) - (:newline))) - "Init args: " - (:value ,(micros/mop:slot-definition-initargs slot)) - (:newline) - "Init form: " - ,(if (micros/mop:slot-definition-initfunction slot) - `(:value ,(micros/mop:slot-definition-initform slot)) - "#") - (:newline) - "Init function: " - (:value ,(micros/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)) - (local-nicknames (package-local-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) - - "Nicknames: " ,@(common-seperated-spec package-nicknames) (:newline) - - ,@(when local-nicknames - `("Package-local nicknames: " (:value ,local-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 - ((float-nan-p f) - ;; try NaN first because the next tests may perform operations - ;; that are undefined for NaNs. - (list "Not a Number.")) - ((not (float-infinity-p f)) - (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))))) - ((> f 0) - (list "Positive infinity.")) - ((< f 0) - (list "Negative infinity.")))) - -(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))) diff --git a/lib/micros/contrib/swank-fuzzy.lisp b/lib/micros/contrib/swank-fuzzy.lisp deleted file mode 100644 index 5353ee20e..000000000 --- a/lib/micros/contrib/swank-fuzzy.lisp +++ /dev/null @@ -1,700 +0,0 @@ -;;; swank-fuzzy.lisp --- fuzzy symbol completion -;; -;; Authors: Brian Downing -;; Tobias C. Rittweiler -;; and others -;; -;; License: Public Domain -;; - - -(in-package :micros) - -(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)))) diff --git a/lib/micros/contrib/swank-hyperdoc.lisp b/lib/micros/contrib/swank-hyperdoc.lisp deleted file mode 100644 index 635947c73..000000000 --- a/lib/micros/contrib/swank-hyperdoc.lisp +++ /dev/null @@ -1,16 +0,0 @@ -(in-package :micros) - -(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)))))) diff --git a/lib/micros/contrib/swank-indentation.lisp b/lib/micros/contrib/swank-indentation.lisp deleted file mode 100644 index 3c245b4cf..000000000 --- a/lib/micros/contrib/swank-indentation.lisp +++ /dev/null @@ -1,138 +0,0 @@ -(in-package :micros) - -(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))))) diff --git a/lib/micros/contrib/swank-listener-hooks.lisp b/lib/micros/contrib/swank-listener-hooks.lisp deleted file mode 100644 index 99d636703..000000000 --- a/lib/micros/contrib/swank-listener-hooks.lisp +++ /dev/null @@ -1,86 +0,0 @@ -;;; swank-listener-hooks.lisp --- listener with special hooks -;; -;; Author: Alan Ruttenberg - -;; 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 :micros) - -(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 () - (micros/contrib/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 micros/contrib/repl::*send-repl-results-function* values))))))) - nil) - -(setq micros/contrib/repl::*listener-eval-function* '%listener-eval) diff --git a/lib/micros/contrib/swank-macrostep.lisp b/lib/micros/contrib/swank-macrostep.lisp deleted file mode 100644 index 8cdac29b7..000000000 --- a/lib/micros/contrib/swank-macrostep.lisp +++ /dev/null @@ -1,225 +0,0 @@ -;;; swank-macrostep.lisp -- fancy macro-expansion via macrostep.el -;; -;; Authors: Luis Oliveira -;; Jon Oddie -;; -;; License: Public Domain - -(defpackage :micros/contrib/macrostep - (:use cl :micros) - (:import-from :micros - #:*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 :micros/contrib/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))) diff --git a/lib/micros/contrib/swank-mrepl.lisp b/lib/micros/contrib/swank-mrepl.lisp deleted file mode 100644 index 18c58bc07..000000000 --- a/lib/micros/contrib/swank-mrepl.lisp +++ /dev/null @@ -1,160 +0,0 @@ -;;; swank-mrepl.lisp -;; -;; Licence: public domain - -(in-package :micros) -(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 :micros/contrib/swank-api - (:use) - (:import-from #:micros . ,api) - (:export . ,api))))) - -(defpackage :micros/contrib/mrepl - (:use :cl :micros/contrib/swank-api) - (:export #:create-mrepl)) - -(in-package :micros/contrib/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 - (micros/backend:send thread `(:serve-channel ,ch))) - (list (channel-id ch) - (micros/backend:thread-id (or thread (micros/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) - (micros/backend:spawn - (lambda () - (with-connection (connection) - (dcase (micros/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))) - (micros/backend:make-output-stream - (lambda (string) - (send-to-remote-channel remote `(:write-string ,string)))))) - -(defun make-listener-input-stream (channel) - (micros/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))))) diff --git a/lib/micros/contrib/swank-package-fu.lisp b/lib/micros/contrib/swank-package-fu.lisp deleted file mode 100644 index 4f0b229c3..000000000 --- a/lib/micros/contrib/swank-package-fu.lisp +++ /dev/null @@ -1,63 +0,0 @@ - -(in-package :micros) - -(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 (micros/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 (micros/mop:slot-definition-readers slot)) - (copy-list (micros/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)))) diff --git a/lib/micros/contrib/swank-presentation-streams.lisp b/lib/micros/contrib/swank-presentation-streams.lisp deleted file mode 100644 index 320f40d70..000000000 --- a/lib/micros/contrib/swank-presentation-streams.lisp +++ /dev/null @@ -1,313 +0,0 @@ -;;; swank-presentation-streams.lisp --- Streams that allow attaching object identities -;;; to portions of output -;;; -;;; Authors: Alan Ruttenberg -;;; Matthias Koeppe -;;; Helmut Eller -;;; -;;; License: This code has been placed in the Public Domain. All warranties -;;; are disclaimed. - -(in-package :micros) - -;; 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))))) - -(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 ) - (pp-end-block stream ">")) - nil)) - (defmethod print-object :around ((pathname pathname) stream) - (micros::presenting-object-if - (micros::can-present-readable-objects stream) - pathname stream (call-next-method)))) - (ccl::def-load-pointers clear-presentations () - (micros::clear-presentation-tables))) - -(in-package :micros) - -#+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 &rest args) - (presenting-object object stream - (apply *saved-%print-unreadable-object* - object stream args))))) - (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) - (micros::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 micros/contrib/repl:*send-repl-results-function* - 'present-repl-results-via-presentation-streams)) diff --git a/lib/micros/contrib/swank-presentations.lisp b/lib/micros/contrib/swank-presentations.lisp deleted file mode 100644 index 6077a303d..000000000 --- a/lib/micros/contrib/swank-presentations.lisp +++ /dev/null @@ -1,241 +0,0 @@ -;;; swank-presentations.lisp --- imitate LispM's presentations -;; -;; Authors: Alan Ruttenberg -;; Luke Gorrie -;; Helmut Eller -;; Matthias Koeppe -;; -;; License: This code has been placed in the Public Domain. All warranties -;; are disclaimed. -;; - -(in-package :micros) - -;;;; 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 micros/contrib/repl:*send-repl-results-function* 'present-repl-results)) diff --git a/lib/micros/contrib/swank-quicklisp.lisp b/lib/micros/contrib/swank-quicklisp.lisp deleted file mode 100644 index 2abf4c7bd..000000000 --- a/lib/micros/contrib/swank-quicklisp.lisp +++ /dev/null @@ -1,15 +0,0 @@ -;;; swank-quicklisp.lisp -- Quicklisp support -;; -;; Authors: Matthew Kennedy -;; License: Public Domain -;; - -(in-package :micros) - -(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."))) diff --git a/lib/micros/contrib/swank-repl.lisp b/lib/micros/contrib/swank-repl.lisp deleted file mode 100644 index 01dc8b705..000000000 --- a/lib/micros/contrib/swank-repl.lisp +++ /dev/null @@ -1,439 +0,0 @@ -;;; swank-repl.lisp --- Server side part of the Lisp listener. -;; -;; License: public domain -(in-package :micros) - -(defpackage :micros/contrib/repl - (:use cl micros/backend) - (:export *send-repl-results-function*) - (:import-from - :micros - - *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 :micros/contrib/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* :started-from-emacs - "When T globally redirect all standard streams to Emacs. -When :STARTED-FROM-EMACS redirect when launched by M-x slime") - -(defun globally-redirect-io-p () - (case *globally-redirect-io* - ((t) t) - (:started-from-emacs nil))) - -(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 (micros:make-output-stream-for-target connection - :repl-result))) - (typecase connection - (multithreaded-connection - (setf (mconn.auto-flush-thread connection) - (make-auto-flush-thread out)))) - (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 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-p) - `((*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*) - (micros: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*) => micros::*FOO-BAR*" - (let ((basename (subseq (symbol-name variable-symbol) 1))) - (intern (format nil "*~A-~A" (string prefix) basename) :micros))) - -(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-p) - (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-* 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-* to *REAL-* 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-p) (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-p)) - ;; 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))))) diff --git a/lib/micros/contrib/swank-sbcl-exts.lisp b/lib/micros/contrib/swank-sbcl-exts.lisp deleted file mode 100644 index c4e791b1f..000000000 --- a/lib/micros/contrib/swank-sbcl-exts.lisp +++ /dev/null @@ -1,62 +0,0 @@ -;;; swank-sbcl-exts.lisp --- Misc extensions for SBCL -;; -;; Authors: Tobias C. Rittweiler -;; -;; License: Public Domain -;; - -(in-package :micros) - -;; 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 (string-downcase 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-upcase instruction)))) - (instr-fn - #+(and - #.(micros/backend:with-symbol '*inst-encoder* 'sb-assem) - #.(micros/backend:with-symbol '*backend-instruction-set-package* 'sb-assem)) - (or (gethash (find-symbol instr-name sb-assem::*backend-instruction-set-package*) - sb-assem::*inst-encoder*) - (find-symbol (format nil "M:~A" instr-name) - sb-assem::*backend-instruction-set-package*)))) - (when (consp instr-fn) - (setf instr-fn (car instr-fn))) - (cond ((functionp instr-fn) - (with-available-arglist (arglist) (arglist instr-fn) - (decode-instruction-arglist instr-name (cdr arglist)))) - ((fboundp 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 (or (get instr-fn :macro) - (macro-function instr-fn)) - arglist - (cdr arglist))))) - (t - (call-next-method)))))))) - - -) ; PROGN diff --git a/lib/micros/contrib/swank-snapshot.lisp b/lib/micros/contrib/swank-snapshot.lisp deleted file mode 100644 index ae7c30cac..000000000 --- a/lib/micros/contrib/swank-snapshot.lisp +++ /dev/null @@ -1,65 +0,0 @@ - -(defpackage :micros/contrib/snapshot - (:use cl) - (:export restore-snapshot save-snapshot background-save-snapshot) - (:import-from swank defslimefun)) -(in-package :micros/contrib/snapshot) - -(defslimefun save-snapshot (image-file) - (micros/backend:save-image image-file - (let ((c micros::*emacs-connection*)) - (lambda () (resurrect c)))) - (format nil "Dumped lisp to ~A" image-file)) - -(defslimefun restore-snapshot (image-file) - (let* ((conn micros::*emacs-connection*) - (stream (micros::connection.socket-io conn)) - (clone (micros/backend:dup (micros/backend:socket-fd stream))) - (style (micros::connection.communication-style conn)) - (repl (if (micros::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)))) - (micros::close-connection conn nil nil) - (micros/backend:exec-image image-file args))) - -(defslimefun background-save-snapshot (image-file) - (let ((connection micros::*emacs-connection*)) - (flet ((complete (success) - (let ((micros::*emacs-connection* connection)) - (micros::background-message - "Dumping lisp image ~A ~:[failed!~;succeeded.~]" - image-file success))) - (awaken () - (resurrect connection))) - (micros/backend:background-save-image image-file - :restart-function #'awaken - :completion-function #'complete) - (format nil "Started dumping lisp to ~A..." image-file)))) - -(in-package :micros) - -(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 (micros/contrib/repl: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) diff --git a/lib/micros/contrib/swank-sprof.lisp b/lib/micros/contrib/swank-sprof.lisp deleted file mode 100644 index d05578968..000000000 --- a/lib/micros/contrib/swank-sprof.lisp +++ /dev/null @@ -1,155 +0,0 @@ -;;; swank-sprof.lisp -;; -;; Authors: Juho Snellman -;; -;; License: MIT -;; - -(in-package :micros) - -#+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 micros/rpc swank/mop - micros/match micros/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 #-#.(micros/backend:with-symbol '%code-entry-point 'sb-kernel) - (sb-kernel::%code-entry-points component) - #+#.(micros/backend:with-symbol '%code-entry-point 'sb-kernel) - (sb-kernel:%code-entry-point component 0))) - (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)) - -) diff --git a/lib/micros/contrib/swank-trace-dialog.lisp b/lib/micros/contrib/swank-trace-dialog.lisp deleted file mode 100644 index 0f6645bdd..000000000 --- a/lib/micros/contrib/swank-trace-dialog.lisp +++ /dev/null @@ -1,262 +0,0 @@ -(defpackage :micros/contrib/trace-dialog - (:use :cl) - (:import-from :micros :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 :micros/contrib/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* (micros/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))) - (micros/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 (micros::ensure-list (retlist-of trace))))))) - (values (nth part-id l) - (< part-id (length l))))) - -(defun useful-backtrace () - (micros/backend:call-with-debugging-environment - #'(lambda () - (loop for i from 0 - for frame in (micros/backend:compute-backtrace 0 20) - collect (list i (micros::frame-to-string frame)))))) - -(defun current-trace () - (gethash (micros/backend:current-thread) *current-trace-by-thread*)) - -(defun (setf current-trace) (trace) - (setf (gethash (micros/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)) - (micros/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) - (micros/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 micros:*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 (micros::to-line arg))) - ,(loop for retval in (micros::ensure-list (retlist-of trace)) - for i from 0 - collect (list i (micros::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) - (micros::call-with-bindings - micros::*inspector-printer-bindings* - #'(lambda () - (let ((trace (find-trace trace-id))) - (when trace - (append - (describe-trace-for-emacs trace) - (list (backtrace-of trace) - (micros::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) - (micros/backend:call-with-lock-held - *trace-lock* - #'(lambda () (setf (fill-pointer *traces*) 0))) - nil) - -;; HACK: `micros::*inspector-history*' is unbound by default and needs -;; a reset in that case so that it won't error `micros::inspect-object' -;; before any other object is inspected in the slime session. -;; -(unless (boundp 'micros::*inspector-history*) - (micros::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 - (micros::inspect-object obj) - (error "No object found with ~a, ~a and ~a" trace-id part-id type)))) diff --git a/lib/micros/contrib/swank-util.lisp b/lib/micros/contrib/swank-util.lisp deleted file mode 100644 index aaaaf8cb0..000000000 --- a/lib/micros/contrib/swank-util.lisp +++ /dev/null @@ -1,61 +0,0 @@ -;;; swank-util.lisp --- stuff of questionable utility -;; -;; License: public domain - -(in-package :micros) - -(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))) diff --git a/lib/micros/lsp-api.lisp b/lib/micros/lsp-api.lisp deleted file mode 100644 index 841ca941c..000000000 --- a/lib/micros/lsp-api.lisp +++ /dev/null @@ -1,211 +0,0 @@ -(defpackage :micros/lsp-api - (:use :cl) - (:export :hover-symbol - :completions - :make-symbol-spec - :symbol-informations - :load-systems - :compile-and-load-file - :eval-for-language-server - :eval-result-value - :eval-result-error)) -(in-package :micros/lsp-api) - -;;; hover-symbol -(defun describe-variable (symbol) - (list "Variable" - (with-output-to-string (stream) - (when (boundp symbol) - (sb-impl::describe-variable symbol stream))))) - -(defun describe-function (symbol) - (list "Function" - (with-output-to-string (stream) - (when (fboundp symbol) - (let ((arglist (cons symbol (micros/backend:arglist symbol)))) - (write-line "```lisp" stream) - (let ((*print-case* :downcase)) - (format stream "~(~A~)~%" arglist)) - (write-line "```" stream) - (let ((doc (documentation symbol 'function))) - (when doc - (write-line doc stream)))))))) - -(defun describe-class (symbol) - (list "Class" - (with-output-to-string (stream) - (sb-impl::describe-class symbol nil stream)))) - -(defun describe-type (symbol) - (list "Type" - (with-output-to-string (stream) - (sb-impl::describe-type symbol stream)))) - -(defun describe-declaration (symbol) - (list "Declaration" - (with-output-to-string (stream) - (sb-impl::describe-declaration symbol stream)))) - -(defun describe-plist (symbol) - (list "Symbol-plist:" - (with-output-to-string (stream) - (let ((plist (symbol-plist symbol))) - (when plist - (loop :for (k v) :on plist :by #'cddr - :do (format stream - " ~@:_~A -> ~A~%" - (prin1-to-string k) - (prin1-to-string v)))))))) - -(defun describe-symbol-in-markdown (symbol) - (string-right-trim '(#\newline #\space) - (with-output-to-string (stream) - (let ((contents - (remove "" - (list (describe-variable symbol) - (describe-function symbol) - (describe-class symbol) - (describe-type symbol) - (describe-declaration symbol) - (describe-plist symbol)) - :key #'second - :test #'string=))) - (loop :for (header body) :in contents - :for first := t :then nil - :do (unless first - (write-line "----------" stream)) - (format stream "## ~A~%" header) - (write-string body stream)))))) - -(defun hover-symbol (symbol-name) - (micros::with-buffer-syntax () - (multiple-value-bind (symbol status) - (micros::parse-symbol symbol-name) - (when status - (describe-symbol-in-markdown symbol))))) - -;;; completions -(defstruct (completed-item (:type list)) - label - classification - signature - documentation - sort-text) - -(defun parse-classification-string (classification-string) - (loop :for classification :in '(:variable - :function - :generic-function - :type - :class - :macro - :special-operator - :package) - :for i :from 0 - :unless (char= #\- (char classification-string i)) - :collect classification)) - -(defun symbol-signature (symbol) - (let ((*print-case* :downcase)) - (handler-case - (princ-to-string (cons symbol (micros::arglist symbol))) - (error () - nil)))) - -(defun completed-string-to-symbol (completed-string default-package-name) - (multiple-value-bind (symbol-name package-name internalp) - (micros::tokenize-symbol-thoroughly completed-string) - (declare (ignore internalp)) - (let ((package (if (null package-name) - (find-package default-package-name) - (find-package package-name)))) - (when package - (find-symbol symbol-name package))))) - -(defun completions (symbol-string package-name) - (destructuring-bind (completions timeout-p) - (micros:fuzzy-completions symbol-string package-name - :limit 100) - (declare (ignore timeout-p)) - (loop :for (completed-string score chunks classification-string) :in completions - :for classification-detail := (format nil "~(~{~A~^, ~}~)" - (parse-classification-string classification-string)) - :for symbol := (completed-string-to-symbol completed-string package-name) - :for signature := (symbol-signature symbol) - :for documentation := (describe-symbol-in-markdown symbol) - :for index :from 0 - :collect (make-completed-item :label completed-string - :classification classification-detail - :signature signature - :documentation documentation - :sort-text (format nil "~10,'0D" index))))) - -;;; symbol-informations -(defstruct (symbol-information (:type list)) - name - detail - kind) - -(defstruct (symbol-spec (:type list)) - name - package) - -(defun find-symbol* (symbol-name package-name) - (let ((package (find-package package-name))) - (when package - (find-symbol symbol-name package)))) - -(defun symbol-kind (symbol) - (cond ((boundp symbol) - :variable) - ((fboundp symbol) - :function) - ((find-class symbol nil) - :class) - ((find-package symbol) - :package))) - -(defun symbol-informations (symbol-specs) - (loop :for (symbol-name package-name) :in symbol-specs - :collect (let ((symbol (find-symbol* symbol-name package-name))) - (make-symbol-information :name symbol-name - :detail (when symbol (symbol-signature symbol)) - :kind (when symbol (symbol-kind symbol)))))) - -;;; -(defun load-systems (system-names) - (ql:quickload system-names)) - -(defun compile-and-load-file (filename) - (uiop:with-temporary-file (:pathname output-file :type "fasl") - (let* ((stream (make-broadcast-stream)) - (*standard-output* stream) - (*error-output* stream)) - (when (uiop:compile-file* filename :output-file output-file) - (load output-file) - t)))) - -(defun safety-read-from-string (string) - (handler-case (values (micros:from-string string)) - (error (e) - (values nil e)))) - -;;; -(defstruct (eval-result (:type list)) - value - error) - -(defun eval-for-language-server (string) - (micros::with-buffer-syntax () - (multiple-value-bind (form error) - (safety-read-from-string string) - (if error - (make-eval-result :value nil - :error (princ-to-string error)) - (handler-case (eval form) - (error (e) - (make-eval-result :value nil - :error (princ-to-string e))) - (:no-error (&rest values) - (make-eval-result :value (format nil "~{~S~^~%~}" values) - :error nil))))))) diff --git a/lib/micros/micros.asd b/lib/micros/micros.asd deleted file mode 100644 index 8b3843ef8..000000000 --- a/lib/micros/micros.asd +++ /dev/null @@ -1,41 +0,0 @@ -(defsystem "micros" - :depends-on () - :version "0.0.0" - :serial t - :components ((:file "packages") - (:module "sbcl" - :pathname "swank" - :components ((:file "backend") - (:file "source-path-parser") - (:file "source-file-cache") - (:file "sbcl") - (:file "gray") - (:file "match") - (:file "rpc"))) - (:file "swank") - (:module "contrib" - :components ((:file "swank-util") - (:file "swank-repl") - (:file "swank-c-p-c" :depends-on ("swank-util")) - (:file "swank-arglists" :depends-on ("swank-c-p-c")) - (:file "swank-fuzzy" :depends-on ("swank-util" "swank-c-p-c")) - (:file "swank-fancy-inspector" :depends-on ("swank-util")) - (:file "swank-presentations" :depends-on ("swank-repl")) - (:file "swank-presentation-streams" :depends-on ("swank-presentations")) - (:file "swank-package-fu") - (:file "swank-hyperdoc") - (:file "swank-sbcl-exts" :depends-on ("swank-arglists")) - (:file "swank-mrepl") - (:file "swank-trace-dialog") - (:file "swank-macrostep") - (:file "swank-quicklisp") - - ;; (:file "swank-asdf") - ;; (:file "swank-buffer-streams") - ;; (:file "clipboard") - ;; (:file "indentation") - ;; (:file "listener-hooks" :depends-on ("swank-repl")) - ;; (:file "snapshot") - ;; (:file "sprof") - )) - (:file "lsp-api"))) diff --git a/lib/micros/packages.lisp b/lib/micros/packages.lisp deleted file mode 100644 index 778a0a2cb..000000000 --- a/lib/micros/packages.lisp +++ /dev/null @@ -1,200 +0,0 @@ -(defpackage micros/backend - (:use cl) - (:export *debug-swank-backend* - *log-output* - sldb-condition - compiler-condition - original-condition - message - source-context - condition - severity - with-compilation-hooks - make-location - location - location-p - location-buffer - location-position - location-hints - position-p - position-pos - print-output-to-string - quit-lisp - references - unbound-slot-filler - declaration-arglist - type-specifier-arglist - with-struct - when-let - defimplementation - converting-errors-to-error-location - make-error-location - deinit-log-output - ;; interrupt macro for the backend - *pending-slime-interrupts* - check-slime-interrupts - *interrupt-queued-handler* - ;; inspector related symbols - emacs-inspect - label-value-line - label-value-line* - boolean-to-feature-expression - with-symbol - choose-symbol - ;; package helper for backend - import-to-swank-mop - import-swank-mop-symbols - ;; - default-directory - set-default-directory - frame-source-location - restart-frame - gdb-initial-commands - sldb-break-on-return - buffer-first-change - - profiled-functions - unprofile-all - profile-report - profile-reset - profile-package - - with-collected-macro-forms - auto-flush-loop - *auto-flush-interval*)) - -(defpackage micros/rpc - (:use :cl) - (:export - read-message - read-packet - swank-reader-error - swank-reader-error.packet - swank-reader-error.cause - write-message)) - -(defpackage micros/match - (:use cl) - (:export match)) - -(defpackage micros/mop - (:use) - (:export - ;; classes - standard-generic-function - standard-slot-definition - standard-method - standard-class - eql-specializer - eql-specializer-object - ;; standard-class readers - class-default-initargs - class-direct-default-initargs - class-direct-slots - class-direct-subclasses - class-direct-superclasses - class-finalized-p - class-name - class-precedence-list - class-prototype - class-slots - specializer-direct-methods - ;; generic function readers - generic-function-argument-precedence-order - generic-function-declarations - generic-function-lambda-list - generic-function-methods - generic-function-method-class - generic-function-method-combination - generic-function-name - ;; method readers - method-generic-function - method-function - method-lambda-list - method-specializers - method-qualifiers - ;; slot readers - slot-definition-allocation - slot-definition-documentation - slot-definition-initargs - slot-definition-initform - slot-definition-initfunction - slot-definition-name - slot-definition-type - slot-definition-readers - slot-definition-writers - slot-boundp-using-class - slot-value-using-class - slot-makunbound-using-class - ;; generic function protocol - compute-applicable-methods-using-classes - finalize-inheritance)) - -(defpackage micros - (:use cl micros/backend micros/match micros/rpc) - (:export #:startup-multiprocessing - #:start-server - #:create-server - #:stop-server - #:restart-server - #:ed-in-emacs - #:inspect-in-emacs - #:print-indentation-lossage - #:invoke-slime-debugger - #:swank-debugger-hook - #:emacs-inspect - ;;#:inspect-slot-for-emacs - ;; These are user-configurable variables: - #:*communication-style* - #:*dont-close* - #:*fasl-pathname-function* - #:*log-events* - #:*use-dedicated-output-stream* - #:*dedicated-output-stream-port* - #:*configure-emacs-indentation* - #:*readtable-alist* - #:*globally-redirect-io* - #:*global-debugger* - #:*sldb-quit-restart* - #:*backtrace-printer-bindings* - #:*default-worker-thread-bindings* - #:*macroexpand-printer-bindings* - #:*swank-pprint-bindings* - #:*record-repl-results* - #:*inspector-verbose* - ;; This is SETFable. - #:debug-on-swank-error - ;; These are re-exported directly from the backend: - #:buffer-first-change - #:frame-source-location - #:gdb-initial-commands - #:restart-frame - #:sldb-step - #:sldb-break - #:sldb-break-on-return - #:profiled-functions - #:profile-report - #:profile-reset - #:unprofile-all - #:profile-package - #:default-directory - #:set-default-directory - #:quit-lisp - #:eval-for-emacs - #:eval-in-emacs - #:ed-rpc - #:ed-rpc-no-wait - #:y-or-n-p-in-emacs - #:*find-definitions-right-trim* - #:*find-definitions-left-trim* - #:*after-toggle-trace-hook* - #:unreadable-result - #:unreadable-result-p - #:unreadable-result-string - #:parse-string - #:from-string - #:to-string - #:*swank-debugger-condition* - #:run-hook-with-args-until-success - #:make-output-function-for-target - #:make-output-stream-for-target)) diff --git a/lib/micros/swank.lisp b/lib/micros/swank.lisp deleted file mode 100644 index 1ad0c7b8b..000000000 --- a/lib/micros/swank.lisp +++ /dev/null @@ -1,3760 +0,0 @@ -;;;; swank.lisp --- Server for SLIME commands. -;;; -;;; This code has been placed in the Public Domain. All warranties -;;; are disclaimed. -;;; -;;; This file defines the "Swank" TCP server for Emacs to talk to. The -;;; code in this file is purely portable Common Lisp. We do require a -;;; smattering of non-portable functions in order to write the server, -;;; so we have defined them in `micros/backend.lisp' and implemented -;;; them separately for each Lisp implementation. These extensions are -;;; available to us here via the `micros/backend' package. - -(in-package :micros) -;;;; Top-level variables, constants, macros - -(defconstant cl-package (find-package :cl) - "The COMMON-LISP package.") - -(defconstant keyword-package (find-package :keyword) - "The KEYWORD package.") - -(defconstant default-server-port 4005 - "The default TCP port for the server (when started manually).") - -(defvar *swank-debug-p* t - "When true, print extra debugging information.") - -(defvar *backtrace-pprint-dispatch-table* - (let ((table (copy-pprint-dispatch nil))) - (flet ((print-string (stream string) - (cond (*print-escape* - (escape-string string stream - :map '((#\" . "\\\"") - (#\\ . "\\\\") - (#\newline . "\\n") - (#\return . "\\r")))) - (t (write-string string stream))))) - (set-pprint-dispatch 'string #'print-string 0 table) - table))) - -(defvar *backtrace-printer-bindings* - `((*print-pretty* . t) - (*print-readably* . nil) - (*print-level* . 4) - (*print-length* . 6) - (*print-lines* . 1) - (*print-right-margin* . 200) - (*print-pprint-dispatch* . ,*backtrace-pprint-dispatch-table*)) - "Pretter settings for printing backtraces.") - -(defvar *default-worker-thread-bindings* '() - "An alist to initialize dynamic variables in worker threads. -The list has the form ((VAR . VALUE) ...). Each variable VAR will be -bound to the corresponding VALUE.") - -(defun call-with-bindings (alist fun) - "Call FUN with variables bound according to ALIST. -ALIST is a list of the form ((VAR . VAL) ...)." - (if (null alist) - (funcall fun) - (let* ((rlist (reverse alist)) - (vars (mapcar #'car rlist)) - (vals (mapcar #'cdr rlist))) - (progv vars vals - (funcall fun))))) - -(defmacro with-bindings (alist &body body) - "See `call-with-bindings'." - `(call-with-bindings ,alist (lambda () ,@body))) - -;;; The `DEFSLIMEFUN' macro defines a function that Emacs can call via -;;; RPC. - -(defmacro defslimefun (name arglist &body rest) - "A DEFUN for functions that Emacs can call by RPC." - `(progn - (defun ,name ,arglist ,@rest) - ;; see - (eval-when (:compile-toplevel :load-toplevel :execute) - (export ',name (symbol-package ',name))))) - -(defun missing-arg () - "A function that the compiler knows will never to return a value. -You can use (MISSING-ARG) as the initform for defstruct slots that -must always be supplied. This way the :TYPE slot option need not -include some arbitrary initial value like NIL." - (error "A required &KEY or &OPTIONAL argument was not supplied.")) - - -;;;; Hooks -;;; -;;; We use Emacs-like `add-hook' and `run-hook' utilities to support -;;; simple indirection. The interface is more CLish than the Emacs -;;; Lisp one. - -(defmacro add-hook (place function) - "Add FUNCTION to the list of values on PLACE." - `(pushnew ,function ,place)) - -(defun run-hook (functions &rest arguments) - "Call each of FUNCTIONS with ARGUMENTS." - (dolist (function functions) - (apply function arguments))) - -(defun run-hook-until-success (functions &rest arguments) - "Call each of FUNCTIONS with ARGUMENTS, stop if any function returns -a truthy value" - (loop for hook in functions - thereis (apply hook arguments))) - -(defvar *new-connection-hook* '() - "This hook is run each time a connection is established. -The connection structure is given as the argument. -Backend code should treat the connection structure as opaque.") - -(defvar *connection-closed-hook* '() - "This hook is run when a connection is closed. -The connection as passed as an argument. -Backend code should treat the connection structure as opaque.") - -(defvar *pre-reply-hook* '() - "Hook run (without arguments) immediately before replying to an RPC.") - -(defvar *after-init-hook* '() - "Hook run after user init files are loaded.") - - -;;;; Connections -;;; -;;; Connection structures represent the network connections between -;;; Emacs and Lisp. Each has a socket stream, a set of user I/O -;;; streams that redirect to Emacs, and optionally a second socket -;;; used solely to pipe user-output to Emacs (an optimization). This -;;; is also the place where we keep everything that needs to be -;;; freed/closed/killed when we disconnect. - -(defstruct (connection - (:constructor %make-connection) - (:conc-name connection.) - (:print-function print-connection)) - ;; The listening socket. (usually closed) - (socket (missing-arg) :type t :read-only t) - ;; Character I/O stream of socket connection. Read-only to avoid - ;; race conditions during initialization. - (socket-io (missing-arg) :type stream :read-only t) - ;; Optional dedicated output socket (backending `user-output' slot). - ;; Has a slot so that it can be closed with the connection. - (dedicated-output nil :type (or stream null)) - ;; Streams that can be used for user interaction, with requests - ;; redirected to Emacs. - (user-input nil :type (or stream null)) - (user-output nil :type (or stream null)) - (user-io nil :type (or stream null)) - ;; Bindings used for this connection (usually streams) - (env '() :type list) - ;; A stream that we use for *trace-output*; if nil, we user user-output. - (trace-output nil :type (or stream null)) - ;; A stream where we send REPL results. - (repl-results nil :type (or stream null)) - ;; Cache of macro-indentation information that has been sent to Emacs. - ;; This is used for preparing deltas to update Emacs's knowledge. - ;; Maps: symbol -> indentation-specification - (indentation-cache (make-hash-table :test 'eq) :type hash-table) - ;; The list of packages represented in the cache: - (indentation-cache-packages '()) - ;; The communication style used. - (communication-style nil :type (member nil :spawn :sigio :fd-handler)) - ) - -(defun print-connection (conn stream depth) - (declare (ignore depth)) - (print-unreadable-object (conn stream :type t :identity t))) - -(defstruct (singlethreaded-connection (:include connection) - (:conc-name sconn.)) - ;; The SIGINT handler we should restore when the connection is - ;; closed. - saved-sigint-handler - ;; A queue of events. Not all events can be processed in order and - ;; we need a place to stored them. - (event-queue '() :type list) - ;; A counter that is incremented whenever an event is added to the - ;; queue. This is used to detected modifications to the event queue - ;; by interrupts. The counter wraps around. - (events-enqueued 0 :type fixnum)) - -(defstruct (multithreaded-connection (:include connection) - (:conc-name mconn.)) - ;; In multithreaded systems we delegate certain tasks to specific - ;; threads. The `reader-thread' is responsible for reading network - ;; requests from Emacs and sending them to the `control-thread'; the - ;; `control-thread' is responsible for dispatching requests to the - ;; threads that should handle them; the `repl-thread' is the one - ;; that evaluates REPL expressions. The control thread dispatches - ;; all REPL evaluations to the REPL thread and for other requests it - ;; spawns new threads. - reader-thread - control-thread - repl-thread - auto-flush-thread - indentation-cache-thread - ;; List of threads that are currently processing requests. We use - ;; this to find the newest/current thread for an interrupt. In the - ;; future we may store here (thread . request-tag) pairs so that we - ;; can interrupt specific requests. - (active-threads '() :type list) - ) - -(defvar *emacs-connection* nil - "The connection to Emacs currently in use.") - -(defun make-connection (socket stream style) - (let ((conn (funcall (ecase style - (:spawn - #'make-multithreaded-connection) - ((:sigio nil :fd-handler) - #'make-singlethreaded-connection)) - :socket socket - :socket-io stream - :communication-style style))) - (run-hook *new-connection-hook* conn) - (send-to-sentinel `(:add-connection ,conn)) - conn)) - -(defslimefun ping (tag) - tag) - -(defun safe-backtrace () - (ignore-errors - (call-with-debugging-environment - (lambda () (backtrace 0 nil))))) - -(define-condition swank-error (error) - ((backtrace :initarg :backtrace :reader swank-error.backtrace) - (condition :initarg :condition :reader swank-error.condition)) - (:report (lambda (c s) (princ (swank-error.condition c) s))) - (:documentation "Condition which carries a backtrace.")) - -(defun signal-swank-error (condition &optional (backtrace (safe-backtrace))) - (error 'swank-error :condition condition :backtrace backtrace)) - -(defvar *debug-on-swank-protocol-error* nil - "When non-nil invoke the system debugger on errors that were -signalled during decoding/encoding the wire protocol. Do not set this -to T unless you want to debug swank internals.") - -(defmacro with-swank-error-handler ((connection) &body body) - "Close the connection on internal `swank-error's." - (let ((conn (gensym))) - `(let ((,conn ,connection)) - (handler-case - (handler-bind ((swank-error - (lambda (condition) - (when *debug-on-swank-protocol-error* - (invoke-default-debugger condition))))) - (progn . ,body)) - (swank-error (condition) - (close-connection ,conn - (swank-error.condition condition) - (swank-error.backtrace condition))))))) - -(defmacro with-panic-handler ((connection) &body body) - "Close the connection on unhandled `serious-condition's." - (let ((conn (gensym))) - `(let ((,conn ,connection)) - (handler-bind ((serious-condition - (lambda (condition) - (close-connection ,conn condition (safe-backtrace)) - (abort condition)))) - . ,body)))) - -(add-hook *new-connection-hook* 'notify-backend-of-connection) -(defun notify-backend-of-connection (connection) - (declare (ignore connection)) - (emacs-connected)) - - -;;;; Utilities - - -;;;;; Logging - -(defvar *swank-io-package* - (let ((package (make-package :micros/io-package :use '()))) - (import '(nil t quote) package) - package)) - -(defvar *log-events* nil) - -(defun init-log-output () - (unless *log-output* - (setq *log-output* (real-output-stream *error-output*)))) - -(add-hook *after-init-hook* 'init-log-output) - -(defun real-input-stream (stream) - (typecase stream - (synonym-stream - (real-input-stream (symbol-value (synonym-stream-symbol stream)))) - (two-way-stream - (real-input-stream (two-way-stream-input-stream stream))) - (t stream))) - -(defun real-output-stream (stream) - (typecase stream - (synonym-stream - (real-output-stream (symbol-value (synonym-stream-symbol stream)))) - (two-way-stream - (real-output-stream (two-way-stream-output-stream stream))) - (t stream))) - -(defvar *event-history* (make-array 40 :initial-element nil) - "A ring buffer to record events for better error messages.") -(defvar *event-history-index* 0) -(defvar *enable-event-history* t) - -(defun log-event (format-string &rest args) - "Write a message to *terminal-io* when *log-events* is non-nil. -Useful for low level debugging." - (with-standard-io-syntax - (let ((*print-readably* nil) - (*print-pretty* nil) - (*package* *swank-io-package*)) - (when *enable-event-history* - (setf (aref *event-history* *event-history-index*) - (format nil "~?" format-string args)) - (setf *event-history-index* - (mod (1+ *event-history-index*) (length *event-history*)))) - (when *log-events* - (write-string (escape-non-ascii (format nil "~?" format-string args)) - *log-output*) - (force-output *log-output*))))) - -(defun event-history-to-list () - "Return the list of events (older events first)." - (let ((arr *event-history*) - (idx *event-history-index*)) - (concatenate 'list (subseq arr idx) (subseq arr 0 idx)))) - -(defun clear-event-history () - (fill *event-history* nil) - (setq *event-history-index* 0)) - -(defun dump-event-history (stream) - (dolist (e (event-history-to-list)) - (dump-event e stream))) - -(defun dump-event (event stream) - (cond ((stringp event) - (write-string (escape-non-ascii event) stream)) - ((null event)) - (t - (write-string - (escape-non-ascii (format nil "Unexpected event: ~A~%" event)) - stream)))) - -(defun escape-non-ascii (string) - "Return a string like STRING but with non-ascii chars escaped." - (cond ((ascii-string-p string) string) - (t (with-output-to-string (out) - (loop for c across string do - (cond ((ascii-char-p c) (write-char c out)) - (t (format out "\\x~4,'0X" (char-code c))))))))) - -(defun ascii-string-p (o) - (and (stringp o) - (every #'ascii-char-p o))) - -(defun ascii-char-p (c) - (<= (char-code c) 127)) - - -;;;;; Helper macros - -(defmacro dcase (value &body patterns) - "Dispatch VALUE to one of PATTERNS. -A cross between `case' and `destructuring-bind'. -The pattern syntax is: - ((HEAD . ARGS) . BODY) -The list of patterns is searched for a HEAD `eq' to the car of -VALUE. If one is found, the BODY is executed with ARGS bound to the -corresponding values in the CDR of VALUE." - (let ((operator (gensym "op-")) - (operands (gensym "rand-")) - (tmp (gensym "tmp-"))) - `(let* ((,tmp ,value) - (,operator (car ,tmp)) - (,operands (cdr ,tmp))) - (case ,operator - ,@(loop for (pattern . body) in patterns collect - (if (eq pattern t) - `(t ,@body) - (destructuring-bind (op &rest rands) pattern - `(,op (destructuring-bind ,rands ,operands - ,@body))))) - ,@(if (eq (caar (last patterns)) t) - '() - `((t (error "dcase failed: ~S" ,tmp)))))))) - - -;;;; Interrupt handling - -;; Usually we'd like to enter the debugger when an interrupt happens. -;; But for some operations, in particular send&receive, it's crucial -;; that those are not interrupted when the mailbox is in an -;; inconsistent/locked state. Obviously, if send&receive don't work we -;; can't communicate and the debugger will not work. To solve that -;; problem, we try to handle interrupts only at certain safe-points. -;; -;; Whenever an interrupt happens we call the function -;; INVOKE-OR-QUEUE-INTERRUPT. Usually this simply invokes the -;; debugger, but if interrupts are disabled the interrupt is put in a -;; queue for later processing. At safe-points, we call -;; CHECK-SLIME-INTERRUPTS which looks at the queue and invokes the -;; debugger if needed. -;; -;; The queue for interrupts is stored in a thread local variable. -;; WITH-CONNECTION sets it up. WITH-SLIME-INTERRUPTS allows -;; interrupts, i.e. the debugger is entered immediately. When we call -;; "user code" or non-problematic code we allow interrupts. When -;; inside WITHOUT-SLIME-INTERRUPTS, interrupts are queued. When we -;; switch from "user code" to more delicate operations we need to -;; disable interrupts. In particular, interrupts should be disabled -;; for SEND and RECEIVE-IF. - -;; If true execute interrupts, otherwise queue them. -;; Note: `with-connection' binds *pending-slime-interrupts*. -(defvar *slime-interrupts-enabled*) - -(defmacro with-interrupts-enabled% (flag body) - `(progn - ,@(if flag '((check-slime-interrupts))) - (multiple-value-prog1 - (let ((*slime-interrupts-enabled* ,flag)) - ,@body) - ,@(if flag '((check-slime-interrupts)))))) - -(defmacro with-slime-interrupts (&body body) - `(with-interrupts-enabled% t ,body)) - -(defmacro without-slime-interrupts (&body body) - `(with-interrupts-enabled% nil ,body)) - -(defun queue-thread-interrupt (thread function) - (interrupt-thread thread - (lambda () - ;; safely interrupt THREAD - (when (invoke-or-queue-interrupt function) - (wake-thread thread))))) - -(defun invoke-or-queue-interrupt (function) - (log-event "invoke-or-queue-interrupt: ~a~%" function) - (cond ((not (boundp '*slime-interrupts-enabled*)) - (without-slime-interrupts - (funcall function))) - (*slime-interrupts-enabled* - (log-event "interrupts-enabled~%") - (funcall function)) - (t - (setq *pending-slime-interrupts* - (nconc *pending-slime-interrupts* - (list function))) - (cond ((cdr *pending-slime-interrupts*) - (log-event "too many queued interrupts~%") - (with-simple-restart (continue "Continue from interrupt") - (handler-bind ((serious-condition #'invoke-slime-debugger)) - (check-slime-interrupts)))) - (t - (log-event "queue-interrupt: ~a~%" function) - (when *interrupt-queued-handler* - (funcall *interrupt-queued-handler*)) - t))))) - - -;;; FIXME: poor name? -(defmacro with-io-redirection ((connection) &body body) - "Execute BODY I/O redirection to CONNECTION. " - `(with-bindings (connection.env ,connection) - . ,body)) - -;; Thread local variable used for flow-control. -;; It's bound by `with-connection'. -(defvar *send-counter*) - -(defmacro with-connection ((connection) &body body) - "Execute BODY in the context of CONNECTION." - `(let ((connection ,connection) - (function (lambda () . ,body))) - (if (eq *emacs-connection* connection) - (funcall function) - (let ((*emacs-connection* connection) - (*pending-slime-interrupts* '()) - (*send-counter* 0)) - (without-slime-interrupts - (with-swank-error-handler (connection) - (with-io-redirection (connection) - (call-with-debugger-hook #'swank-debugger-hook - function)))))))) - -(defun call-with-retry-restart (msg thunk) - (loop (with-simple-restart (retry "~a" msg) - (return (funcall thunk))))) - -(defmacro with-retry-restart ((&key (msg "Retry.")) &body body) - (check-type msg string) - `(call-with-retry-restart ,msg (lambda () ,@body))) - -(defmacro with-struct* ((conc-name get obj) &body body) - (let ((var (gensym))) - `(let ((,var ,obj)) - (macrolet ((,get (slot) - (let ((getter (intern (concatenate 'string - ',(string conc-name) - (string slot)) - (symbol-package ',conc-name)))) - `(,getter ,',var)))) - ,@body)))) - -(defmacro define-special (name doc) - "Define a special variable NAME with doc string DOC. -This is like defvar, but NAME will not be initialized." - `(progn - (defvar ,name) - (setf (documentation ',name 'variable) ,doc))) - - -;;;;; Sentinel -;;; -;;; The sentinel thread manages some global lists. -;;; FIXME: Overdesigned? - -(defvar *connections* '() - "List of all active connections, with the most recent at the front.") - -(defvar *servers* '() - "A list ((server-socket port thread) ...) describing the listening sockets. -Used to close sockets on server shutdown or restart.") - -;; FIXME: we simply access the global variable here. We could ask the -;; sentinel thread instead but then we still have the problem that the -;; connection could be closed before we use it. -(defun default-connection () - "Return the 'default' Emacs connection. -This connection can be used to talk with Emacs when no specific -connection is in use, i.e. *EMACS-CONNECTION* is NIL. - -The default connection is defined (quite arbitrarily) as the most -recently established one." - (car *connections*)) - -(defun start-sentinel () - (unless (find-registered 'sentinel) - (let ((thread (spawn #'sentinel :name "Swank Sentinel"))) - (register-thread 'sentinel thread)))) - -(defun sentinel () - (catch 'exit-sentinel - (loop (sentinel-serve (receive))))) - -(defun send-to-sentinel (msg) - (let ((sentinel (find-registered 'sentinel))) - (cond (sentinel (send sentinel msg)) - (t (sentinel-serve msg))))) - -(defun sentinel-serve (msg) - (dcase msg - ((:add-connection conn) - (push conn *connections*)) - ((:close-connection connection condition backtrace) - (close-connection% connection condition backtrace) - (sentinel-maybe-exit)) - ((:add-server socket port thread) - (push (list socket port thread) *servers*)) - ((:stop-server key port) - (sentinel-stop-server key port) - (sentinel-maybe-exit)))) - -(defun sentinel-stop-server (key value) - (let ((probe (find value *servers* :key (ecase key - (:socket #'car) - (:port #'cadr))))) - (cond (probe - (setq *servers* (delete probe *servers*)) - (destructuring-bind (socket _port thread) probe - (declare (ignore _port)) - (ignore-errors (close-socket socket)) - (when (and thread - (thread-alive-p thread) - (not (eq thread (current-thread)))) - (ignore-errors (kill-thread thread))))) - (t - (warn "No server for ~s: ~s" key value))))) - -(defun sentinel-maybe-exit () - (when (and (null *connections*) - (null *servers*) - (and (current-thread) - (eq (find-registered 'sentinel) - (current-thread)))) - (register-thread 'sentinel nil) - (throw 'exit-sentinel nil))) - - -;;;;; Misc - -(defun use-threads-p () - (eq (connection.communication-style *emacs-connection*) :spawn)) - -(defun current-thread-id () - (thread-id (current-thread))) - -(declaim (inline ensure-list)) -(defun ensure-list (thing) - (if (listp thing) thing (list thing))) - - -;;;;; Symbols - -;; FIXME: this docstring is more confusing than helpful. -(defun symbol-status (symbol &optional (package (symbol-package symbol))) - "Returns one of - - :INTERNAL if the symbol is _present_ in PACKAGE as an _internal_ symbol, - - :EXTERNAL if the symbol is _present_ in PACKAGE as an _external_ symbol, - - :INHERITED if the symbol is _inherited_ by PACKAGE through USE-PACKAGE, - but is not _present_ in PACKAGE, - - or NIL if SYMBOL is not _accessible_ in PACKAGE. - - -Be aware not to get confused with :INTERNAL and how \"internal -symbols\" are defined in the spec; there is a slight mismatch of -definition with the Spec and what's commonly meant when talking -about internal symbols most times. As the spec says: - - In a package P, a symbol S is - - _accessible_ if S is either _present_ in P itself or was - inherited from another package Q (which implies - that S is _external_ in Q.) - - You can check that with: (AND (SYMBOL-STATUS S P) T) - - - _present_ if either P is the /home package/ of S or S has been - imported into P or exported from P by IMPORT, or - EXPORT respectively. - - Or more simply, if S is not _inherited_. - - You can check that with: (LET ((STATUS (SYMBOL-STATUS S P))) - (AND STATUS - (NOT (EQ STATUS :INHERITED)))) - - - _external_ if S is going to be inherited into any package that - /uses/ P by means of USE-PACKAGE, MAKE-PACKAGE, or - DEFPACKAGE. - - Note that _external_ implies _present_, since to - make a symbol _external_, you'd have to use EXPORT - which will automatically make the symbol _present_. - - You can check that with: (EQ (SYMBOL-STATUS S P) :EXTERNAL) - - - _internal_ if S is _accessible_ but not _external_. - - You can check that with: (LET ((STATUS (SYMBOL-STATUS S P))) - (AND STATUS - (NOT (EQ STATUS :EXTERNAL)))) - - - Notice that this is *different* to - (EQ (SYMBOL-STATUS S P) :INTERNAL) - because what the spec considers _internal_ is split up into two - explicit pieces: :INTERNAL, and :INHERITED; just as, for instance, - CL:FIND-SYMBOL does. - - The rationale is that most times when you speak about \"internal\" - symbols, you're actually not including the symbols inherited - from other packages, but only about the symbols directly specific - to the package in question. -" - (when package ; may be NIL when symbol is completely uninterned. - (check-type symbol symbol) (check-type package package) - (multiple-value-bind (present-symbol status) - (find-symbol (symbol-name symbol) package) - (and (eq symbol present-symbol) status)))) - -(defun symbol-external-p (symbol &optional (package (symbol-package symbol))) - "True if SYMBOL is external in PACKAGE. -If PACKAGE is not specified, the home package of SYMBOL is used." - (eq (symbol-status symbol package) :external)) - - -;;;; TCP Server - -(defvar *communication-style* (preferred-communication-style)) - -(defvar *dont-close* nil - "Default value of :dont-close argument to start-server and - create-server.") - -(defparameter *loopback-interface* "localhost") - -(defun start-server (port-file &key (style *communication-style*) - (dont-close *dont-close*)) - "Start the server and write the listen port number to PORT-FILE. -This is the entry point for Emacs." - (setup-server 0 - (lambda (port) (announce-server-port port-file port)) - style dont-close nil)) - -(defun create-server (&key (port default-server-port) - (style *communication-style*) - (dont-close *dont-close*) - interface - backlog) - "Start a SWANK server on PORT running in STYLE. -If DONT-CLOSE is true then the listen socket will accept multiple -connections, otherwise it will be closed after the first. - -Optionally, an INTERFACE could be specified and swank will bind -the PORT on this interface. By default, interface is \"localhost\"." - (let ((*loopback-interface* (or interface - *loopback-interface*))) - (setup-server port #'simple-announce-function - style dont-close backlog))) - -(defun find-external-format-or-lose (coding-system) - (or (find-external-format coding-system) - (error "Unsupported coding system: ~s" coding-system))) - -(defmacro restart-loop (form &body clauses) - "Executes FORM, with restart-case CLAUSES which have a chance to modify FORM's -environment before trying again (by returning normally) or giving up (through an -explicit transfer of control), all within an implicit block named nil. -e.g.: (restart-loop (http-request url) (use-value (new) (setq url new)))" - `(loop (restart-case (return ,form) ,@clauses))) - -(defun socket-quest (port backlog) - (restart-loop (create-socket *loopback-interface* port :backlog backlog) - (use-value (&optional (new-port (1+ port))) - :report (lambda (stream) (format stream "Try a port other than ~D" port)) - :interactive - (lambda () - (format *query-io* "Enter port (defaults to ~D): " (1+ port)) - (finish-output *query-io*) ; necessary for tunnels - (ignore-errors (list (parse-integer (read-line *query-io*))))) - (setq port new-port)))) - -(defun setup-server (port announce-fn style dont-close backlog) - (init-log-output) - (let* ((socket (socket-quest port backlog)) - (port (local-port socket))) - (funcall announce-fn port) - (labels ((serve () (accept-connections socket style dont-close)) - (note () (send-to-sentinel `(:add-server ,socket ,port - ,(current-thread)))) - (serve-loop () (note) (loop do (serve) while dont-close))) - (ecase style - (:spawn (initialize-multiprocessing - (lambda () - (start-sentinel) - (spawn #'serve-loop :name (format nil "micros ~s" port))))) - ((:fd-handler :sigio) - (note) - (add-fd-handler socket #'serve)) - ((nil) (serve-loop)))) - port)) - -(defun stop-server (port) - "Stop server running on PORT." - (send-to-sentinel `(:stop-server :port ,port))) - -(defun restart-server (&key (port default-server-port) - (style *communication-style*) - (dont-close *dont-close*)) - "Stop the server listening on PORT, then start a new SWANK server -on PORT running in STYLE. If DONT-CLOSE is true then the listen socket -will accept multiple connections, otherwise it will be closed after the -first." - (stop-server port) - (sleep 5) - (create-server :port port :style style :dont-close dont-close)) - -(defun accept-connections (socket style dont-close) - (unwind-protect - (let ((client (accept-connection socket :external-format nil - :buffering t))) - (authenticate-client client) - (serve-requests (make-connection socket client style))) - (unless dont-close - (send-to-sentinel `(:stop-server :socket ,socket))))) - -(defun authenticate-client (stream) - (let ((secret (slime-secret))) - (when secret - (set-stream-timeout stream 20) - (let ((first-val (read-packet stream))) - (unless (and (stringp first-val) (string= first-val secret)) - (error "Incoming connection doesn't know the password."))) - (set-stream-timeout stream nil)))) - -(defun slime-secret () - "Finds the magic secret from the user's home directory. Returns nil -if the file doesn't exist; otherwise the first line of the file." - (with-open-file (in - (merge-pathnames (user-homedir-pathname) #p".slime-secret") - :if-does-not-exist nil) - (and in (read-line in nil "")))) - -(defun serve-requests (connection) - "Read and process all requests on connections." - (etypecase connection - (multithreaded-connection - (spawn-threads-for-connection connection)) - (singlethreaded-connection - (ecase (connection.communication-style connection) - ((nil) (simple-serve-requests connection)) - (:sigio (install-sigio-handler connection)) - (:fd-handler (install-fd-handler connection)))))) - -(defun stop-serving-requests (connection) - (etypecase connection - (multithreaded-connection - (cleanup-connection-threads connection)) - (singlethreaded-connection - (ecase (connection.communication-style connection) - ((nil)) - (:sigio (deinstall-sigio-handler connection)) - (:fd-handler (deinstall-fd-handler connection)))))) - -(defun announce-server-port (file port) - (with-open-file (s file - :direction :output - :if-exists :error - :if-does-not-exist :create) - (format s "~S~%" port)) - (simple-announce-function port)) - -(defun simple-announce-function (port) - (when *swank-debug-p* - (format *log-output* "~&;; Swank started at port: ~D.~%" port) - (force-output *log-output*))) - - -;;;;; Event Decoding/Encoding - -(defun decode-message (stream) - "Read an S-expression from STREAM using the SLIME protocol." - (log-event "decode-message~%") - (without-slime-interrupts - (handler-bind ((error #'signal-swank-error)) - (handler-case (read-message stream *swank-io-package*) - (swank-reader-error (c) - `(:reader-error ,(swank-reader-error.packet c) - ,(swank-reader-error.cause c))))))) - -(defun encode-message (message stream) - "Write an S-expression to STREAM using the SLIME protocol." - (log-event "encode-message~%") - (without-slime-interrupts - (handler-bind ((error #'signal-swank-error)) - (write-message message *swank-io-package* stream)))) - - -;;;;; Event Processing - -(defvar *sldb-quit-restart* nil - "The restart that will be invoked when the user calls sldb-quit.") - -;; Establish a top-level restart and execute BODY. -;; Execute K if the restart is invoked. -(defmacro with-top-level-restart ((connection k) &body body) - `(with-connection (,connection) - (restart-case - (let ((*sldb-quit-restart* (find-restart 'abort))) - ,@body) - (abort (&optional v) - :report "Return to SLIME's top level." - (declare (ignore v)) - (force-user-output) - ,k)))) - -(defun handle-requests (connection &optional timeout) - "Read and process :emacs-rex requests. -The processing is done in the extent of the toplevel restart." - (with-connection (connection) - (cond (*sldb-quit-restart* - (process-requests timeout)) - (t - (tagbody - start - (with-top-level-restart (connection (go start)) - (process-requests timeout))))))) - -(defun process-requests (timeout) - "Read and process requests from Emacs." - (loop - (multiple-value-bind (event timeout?) - (wait-for-event `(or (:emacs-rex . _) - (:emacs-channel-send . _)) - timeout) - (when timeout? (return)) - (dcase event - ((:emacs-rex &rest args) (apply #'eval-for-emacs args)) - ((:emacs-channel-send channel (selector &rest args)) - (channel-send channel selector args)))))) - -(defun current-socket-io () - (connection.socket-io *emacs-connection*)) - -(defun close-connection (connection condition backtrace) - (send-to-sentinel `(:close-connection ,connection ,condition ,backtrace))) - -(defun close-connection% (c condition backtrace) - (let ((*debugger-hook* nil)) - (log-event "close-connection: ~a ...~%" condition) - (format *log-output* "~&;; micros:close-connection: ~A~%" - (escape-non-ascii (safe-condition-message condition))) - (stop-serving-requests c) - (close (connection.socket-io c)) - (when (connection.dedicated-output c) - (ignore-errors (close (connection.dedicated-output c)))) - (setf *connections* (remove c *connections*)) - (run-hook *connection-closed-hook* c) - (when (and condition (not (typep condition 'end-of-file))) - (finish-output *log-output*) - (format *log-output* "~&;; Event history start:~%") - (dump-event-history *log-output*) - (format *log-output* "~ -;; Event history end.~%~ -;; Backtrace:~%~{~A~%~}~ -;; Connection to Emacs lost. [~%~ -;; condition: ~A~%~ -;; type: ~S~%~ -;; style: ~S]~%" - (loop for (i f) in backtrace collect - (ignore-errors - (format nil "~d: ~a" i (escape-non-ascii f)))) - (escape-non-ascii (safe-condition-message condition) ) - (type-of condition) - (connection.communication-style c))) - (finish-output *log-output*) - (log-event "close-connection ~a ... done.~%" condition))) - -;;;;;; Thread based communication - -(defun read-loop (connection) - (let ((input-stream (connection.socket-io connection)) - (control-thread (mconn.control-thread connection))) - (with-swank-error-handler (connection) - (loop (send control-thread (decode-message input-stream)))))) - -(defun dispatch-loop (connection) - (let ((*emacs-connection* connection)) - (with-panic-handler (connection) - (loop (dispatch-event connection (receive)))))) - -(defgeneric thread-for-evaluation (connection id) - (:documentation "Find or create a thread to evaluate the next request.") - (:method ((connection multithreaded-connection) (id (eql t))) - (spawn-worker-thread connection)) - (:method ((connection multithreaded-connection) (id (eql :find-existing))) - (car (mconn.active-threads connection))) - (:method (connection (id integer)) - (declare (ignorable connection)) - (find-thread id)) - (:method ((connection singlethreaded-connection) id) - (declare (ignorable connection connection id)) - (current-thread))) - -(defun interrupt-worker-thread (connection id) - (let ((thread (thread-for-evaluation connection - (cond ((eq id t) :find-existing) - (t id))))) - (log-event "interrupt-worker-thread: ~a ~a~%" id thread) - (if thread - (etypecase connection - (multithreaded-connection - (queue-thread-interrupt thread #'simple-break)) - (singlethreaded-connection - (simple-break))) - (encode-message (list :debug-condition (current-thread-id) - (format nil "Thread with id ~a not found" - id)) - (current-socket-io))))) - -(defun spawn-worker-thread (connection) - (spawn (lambda () - (with-bindings *default-worker-thread-bindings* - (with-top-level-restart (connection nil) - (apply #'eval-for-emacs - (cdr (wait-for-event `(:emacs-rex . _))))))) - :name "worker")) - -(defun add-active-thread (connection thread) - (etypecase connection - (multithreaded-connection - (push thread (mconn.active-threads connection))) - (singlethreaded-connection))) - -(defun remove-active-thread (connection thread) - (etypecase connection - (multithreaded-connection - (setf (mconn.active-threads connection) - (delete thread (mconn.active-threads connection) :count 1))) - (singlethreaded-connection))) - -(defparameter *event-hook* nil) - -(defun dispatch-event (connection event) - "Handle an event triggered either by Emacs or within Lisp." - (log-event "dispatch-event: ~s~%" event) - (or (run-hook-until-success *event-hook* connection event) - (dcase event - ((:emacs-rex form package thread-id id) - (let ((thread (thread-for-evaluation connection thread-id))) - (cond (thread - (add-active-thread connection thread) - (send-event thread `(:emacs-rex ,form ,package ,id))) - (t - (encode-message - (list :invalid-rpc id - (format nil "Thread not found: ~s" thread-id)) - (current-socket-io)))))) - ((:return thread &rest args) - (remove-active-thread connection thread) - (encode-message `(:return ,@args) (current-socket-io))) - ((:emacs-interrupt thread-id) - (interrupt-worker-thread connection thread-id)) - ((:interrupt-thread request-id) - (interrupt-worker-thread connection (get-thread-id request-id))) - (((:write-string - :debug :debug-condition :debug-activate :debug-return :channel-send - :presentation-start :presentation-end - :new-package :new-features :ed :indentation-update - :eval :eval-no-wait :background-message :inspect :ping - :y-or-n-p :read-from-minibuffer :read-string :read-aborted :test-delay - :write-image :ed-rpc :ed-rpc-no-wait) - &rest _) - (declare (ignore _)) - (encode-message event (current-socket-io))) - (((:emacs-pong :emacs-return :emacs-return-string :ed-rpc-forbidden) - thread-id &rest args) - (send-event (find-thread thread-id) (cons (car event) args))) - ((:emacs-channel-send channel-id msg) - (let ((ch (find-channel channel-id))) - (send-event (channel-thread ch) `(:emacs-channel-send ,ch ,msg)))) - ((:reader-error packet condition) - (encode-message `(:reader-error ,packet - ,(safe-condition-message condition)) - (current-socket-io)))))) - - -(defun send-event (thread event) - (log-event "send-event: ~s ~s~%" thread event) - (let ((c *emacs-connection*)) - (etypecase c - (multithreaded-connection - (send thread event)) - (singlethreaded-connection - (setf (sconn.event-queue c) (nconc (sconn.event-queue c) (list event))) - (setf (sconn.events-enqueued c) (mod (1+ (sconn.events-enqueued c)) - most-positive-fixnum)))))) - -(defun send-to-emacs (event) - "Send EVENT to Emacs." - ;;(log-event "send-to-emacs: ~a" event) - (without-slime-interrupts - (let ((c *emacs-connection*)) - (etypecase c - (multithreaded-connection - (send (mconn.control-thread c) event)) - (singlethreaded-connection - (dispatch-event c event))) - (maybe-slow-down)))) - - -;;;;;; Flow control - -;; After sending N (usually 100) messages we slow down and ping Emacs -;; to make sure that everything we have sent so far was received. - -(defconstant send-counter-limit 100) - -(defun maybe-slow-down () - (let ((counter (incf *send-counter*))) - (when (< send-counter-limit counter) - (setf *send-counter* 0) - (ping-pong)))) - -(defun ping-pong () - (let* ((tag (make-tag)) - (pattern `(:emacs-pong ,tag))) - (send-to-emacs `(:ping ,(current-thread-id) ,tag)) - (wait-for-event pattern))) - - -(defun wait-for-event (pattern &optional timeout) - "Scan the event queue for PATTERN and return the event. -If TIMEOUT is 'nil wait until a matching event is enqued. -If TIMEOUT is 't only scan the queue without waiting. -The second return value is t if the timeout expired before a matching -event was found." - (log-event "wait-for-event: ~s ~s~%" pattern timeout) - (without-slime-interrupts - (let ((c *emacs-connection*)) - (etypecase c - (multithreaded-connection - (receive-if (lambda (e) (event-match-p e pattern)) timeout)) - (singlethreaded-connection - (wait-for-event/event-loop c pattern timeout)))))) - -(defun wait-for-event/event-loop (connection pattern timeout) - (assert (or (not timeout) (eq timeout t))) - (loop - (check-slime-interrupts) - (let ((event (poll-for-event connection pattern))) - (when event (return (car event)))) - (let ((events-enqueued (sconn.events-enqueued connection)) - (ready (wait-for-input (list (current-socket-io)) timeout))) - (cond ((and timeout (not ready)) - (return (values nil t))) - ((or (/= events-enqueued (sconn.events-enqueued connection)) - (eq ready :interrupt)) - ;; rescan event queue, interrupts may enqueue new events - ) - (t - (assert (equal ready (list (current-socket-io)))) - (dispatch-event connection - (decode-message (current-socket-io)))))))) - -(defun poll-for-event (connection pattern) - (let* ((c connection) - (tail (member-if (lambda (e) (event-match-p e pattern)) - (sconn.event-queue c)))) - (when tail - (setf (sconn.event-queue c) - (nconc (ldiff (sconn.event-queue c) tail) (cdr tail))) - tail))) - -;;; FIXME: Make this use SWANK-MATCH. -(defun event-match-p (event pattern) - (cond ((or (keywordp pattern) (numberp pattern) (stringp pattern) - (member pattern '(nil t))) - (equal event pattern)) - ((symbolp pattern) t) - ((consp pattern) - (case (car pattern) - ((or) (some (lambda (p) (event-match-p event p)) (cdr pattern))) - (t (and (consp event) - (and (event-match-p (car event) (car pattern)) - (event-match-p (cdr event) (cdr pattern))))))) - (t (error "Invalid pattern: ~S" pattern)))) - - - -(defun spawn-threads-for-connection (connection) - (setf (mconn.control-thread connection) - (spawn (lambda () (control-thread connection)) - :name "control-thread")) - connection) - -(defun control-thread (connection) - (with-struct* (mconn. @ connection) - (setf (@ control-thread) (current-thread)) - (setf (@ reader-thread) (spawn (lambda () (read-loop connection)) - :name "reader-thread")) - (setf (@ indentation-cache-thread) - (spawn (lambda () (indentation-cache-loop connection)) - :name "swank-indentation-cache-thread")) - (dispatch-loop connection))) - -(defun cleanup-connection-threads (connection) - (let* ((c connection) - (threads (list (mconn.repl-thread c) - (mconn.reader-thread c) - (mconn.control-thread c) - (mconn.auto-flush-thread c) - (mconn.indentation-cache-thread c)))) - (dolist (thread threads) - (when (and thread - (thread-alive-p thread) - (not (equal (current-thread) thread))) - (ignore-errors (kill-thread thread)))))) - -;;;;;; Signal driven IO - -(defun install-sigio-handler (connection) - (add-sigio-handler (connection.socket-io connection) - (lambda () (process-io-interrupt connection))) - (handle-requests connection t)) - -(defvar *io-interupt-level* 0) - -(defun process-io-interrupt (connection) - (log-event "process-io-interrupt ~d ...~%" *io-interupt-level*) - (let ((*io-interupt-level* (1+ *io-interupt-level*))) - (invoke-or-queue-interrupt - (lambda () (handle-requests connection t)))) - (log-event "process-io-interrupt ~d ... done ~%" *io-interupt-level*)) - -(defun deinstall-sigio-handler (connection) - (log-event "deinstall-sigio-handler...~%") - (remove-sigio-handlers (connection.socket-io connection)) - (log-event "deinstall-sigio-handler...done~%")) - -;;;;;; SERVE-EVENT based IO - -(defun install-fd-handler (connection) - (add-fd-handler (connection.socket-io connection) - (lambda () (handle-requests connection t))) - (setf (sconn.saved-sigint-handler connection) - (install-sigint-handler - (lambda () - (invoke-or-queue-interrupt - (lambda () (dispatch-interrupt-event connection)))))) - (handle-requests connection t)) - -(defun dispatch-interrupt-event (connection) - (with-connection (connection) - (dispatch-event connection `(:emacs-interrupt ,(current-thread-id))))) - -(defun deinstall-fd-handler (connection) - (log-event "deinstall-fd-handler~%") - (remove-fd-handlers (connection.socket-io connection)) - (install-sigint-handler (sconn.saved-sigint-handler connection))) - -;;;;;; Simple sequential IO - -(defun simple-serve-requests (connection) - (unwind-protect - (with-connection (connection) - (call-with-user-break-handler - (lambda () - (invoke-or-queue-interrupt - (lambda () (dispatch-interrupt-event connection)))) - (lambda () - (with-simple-restart (close-connection "Close SLIME connection.") - (let* ((stdin (real-input-stream *standard-input*)) - (*standard-input* (make-repl-input-stream connection - stdin))) - (tagbody toplevel - (with-top-level-restart (connection (go toplevel)) - (simple-repl)))))))) - (close-connection connection nil (safe-backtrace)))) - -;; this is signalled when our custom stream thinks the end-of-file is reached. -;; (not when the end-of-file on the socket is reached) -(define-condition end-of-repl-input (end-of-file) ()) - -(defun simple-repl () - (loop - (format t "~a> " (package-string-for-prompt *package*)) - (force-output) - (let ((form (handler-case (read) - (end-of-repl-input () (return))))) - (let ((- form) - (values (multiple-value-list (eval form)))) - (setq *** ** ** * * (car values) - /// // // / / values - +++ ++ ++ + + form) - (cond ((null values) (format t "; No values~&")) - (t (mapc (lambda (v) (format t "~s~&" v)) values))))))) - -(defun make-repl-input-stream (connection stdin) - (make-input-stream - (lambda () (repl-input-stream-read connection stdin)))) - -(defun repl-input-stream-read (connection stdin) - (loop - (let* ((socket (connection.socket-io connection)) - (inputs (list socket stdin)) - (ready (wait-for-input inputs))) - (cond ((eq ready :interrupt) - (check-slime-interrupts)) - ((member socket ready) - ;; A Slime request from Emacs is pending; make sure to - ;; redirect IO to the REPL buffer. - (with-simple-restart (process-input "Continue reading input.") - (let ((*sldb-quit-restart* (find-restart 'process-input))) - (with-io-redirection (connection) - (handle-requests connection t))))) - ((member stdin ready) - ;; User typed something into the *inferior-lisp* buffer, - ;; so do not redirect. - (return (read-non-blocking stdin))) - (t (assert (null ready))))))) - -(defun read-non-blocking (stream) - (with-output-to-string (str) - (handler-case - (loop (let ((c (read-char-no-hang stream))) - (unless c (return)) - (write-char c str))) - (end-of-file () (error 'end-of-repl-input :stream stream))))) - - -;;; Channels - -;; FIXME: should be per connection not global. -(defvar *channels* '()) -(defvar *channel-counter* 0) - -(defclass channel () - ((id :reader channel-id) - (thread :initarg :thread :initform (current-thread) :reader channel-thread) - (name :initarg :name :initform nil))) - -(defmethod initialize-instance :after ((ch channel) &key) - (with-slots (id) ch - (setf id (incf *channel-counter*)) - (push (cons id ch) *channels*))) - -(defmethod print-object ((c channel) stream) - (print-unreadable-object (c stream :type t) - (with-slots (id name) c - (format stream "~d ~a" id name)))) - -(defun find-channel (id) - (cdr (assoc id *channels*))) - -(defgeneric channel-send (channel selector args)) - -(defmacro define-channel-method (selector (channel &rest args) &body body) - `(defmethod channel-send (,channel (selector (eql ',selector)) args) - (destructuring-bind ,args args - . ,body))) - -(defun send-to-remote-channel (channel-id msg) - (send-to-emacs `(:channel-send ,channel-id ,msg))) - - - -(defvar *slime-features* nil - "The feature list that has been sent to Emacs.") - -(defun send-oob-to-emacs (object) - (send-to-emacs object)) - -;; FIXME: belongs to swank-repl.lisp -(defun force-user-output () - (force-output (connection.user-io *emacs-connection*))) - -(add-hook *pre-reply-hook* 'force-user-output) - -;; FIXME: belongs to swank-repl.lisp -(defun clear-user-input () - (clear-input (connection.user-input *emacs-connection*))) - -;; FIXME: not thread save. -(defvar *tag-counter* 0) - -(defun make-tag () - (setq *tag-counter* (mod (1+ *tag-counter*) (expt 2 22)))) - -(defun y-or-n-p-in-emacs (format-string &rest arguments) - "Like y-or-n-p, but ask in the Emacs minibuffer." - (let ((tag (make-tag)) - (question (apply #'format nil format-string arguments))) - (force-output) - (send-to-emacs `(:y-or-n-p ,(current-thread-id) ,tag ,question)) - (third (wait-for-event `(:emacs-return ,tag result))))) - -(defun read-from-minibuffer-in-emacs (prompt &optional initial-value) - "Ask user a question in Emacs' minibuffer. Returns \"\" when user -entered nothing, returns NIL when user pressed C-g." - (check-type prompt string) (check-type initial-value (or null string)) - (let ((tag (make-tag))) - (force-output) - (send-to-emacs `(:read-from-minibuffer ,(current-thread-id) ,tag - ,prompt ,initial-value)) - (third (wait-for-event `(:emacs-return ,tag result))))) - -(defstruct (unreadable-result - (:constructor make-unreadable-result (string)) - (:copier nil) - (:print-object - (lambda (object stream) - (print-unreadable-object (object stream :type t) - (princ (unreadable-result-string object) stream))))) - string) - -(defun symbol-name-for-emacs (symbol) - (check-type symbol symbol) - (let ((name (string-downcase (symbol-name symbol)))) - (if (keywordp symbol) - (concatenate 'string ":" name) - name))) - -(defun process-form-for-emacs (form) - "Returns a string which emacs will read as equivalent to -FORM. FORM can contain lists, strings, characters, symbols and -numbers. - -Characters are converted emacs' ? notaion, strings are left -as they are (except for espacing any nested \" chars, numbers are -printed in base 10 and symbols are printed as their symbol-name -converted to lower case." - (etypecase form - (string (format nil "~S" form)) - (cons (format nil "(~A . ~A)" - (process-form-for-emacs (car form)) - (process-form-for-emacs (cdr form)))) - (character (format nil "?~C" form)) - (symbol (symbol-name-for-emacs form)) - (number (let ((*print-base* 10)) - (princ-to-string form))))) - -(defun wait-for-emacs-return (tag) - (let ((event (caddr (wait-for-event `(:emacs-return ,tag result))))) - (dcase event - ((:unreadable value) (make-unreadable-result value)) - ((:ok value) value) - ((:error kind . data) (error "~a: ~{~a~}" kind data)) - ((:abort) (abort)) - ;; only in reply to :ed-rpc{-no-wait} events. - ((:ed-rpc-forbidden fn) (error "ED-RPC forbidden for ~a" fn))))) - -(defun eval-in-emacs (form &optional nowait) - "Eval FORM in Emacs. -`slime-enable-evaluate-in-emacs' should be set to T on the Emacs side." - (cond (nowait - (send-to-emacs `(:eval-no-wait ,(process-form-for-emacs form)))) - (t - (force-output) - (let ((tag (make-tag))) - (send-to-emacs `(:eval ,(current-thread-id) ,tag - ,(process-form-for-emacs form))) - (wait-for-emacs-return tag))))) - -(defun ed-rpc-no-wait (fn &rest args) - "Invoke FN in Emacs (or some lesser editor) and don't wait for the result." - (send-to-emacs `(:ed-rpc-no-wait ,(symbol-name-for-emacs fn) ,@args)) - (values)) - -(defun ed-rpc (fn &rest args) - "Invoke FN in Emacs (or some lesser editor). FN should be defined in -Emacs Lisp via `defslimefun' or otherwise marked as RPCallable." - (let ((tag (make-tag))) - (send-to-emacs `(:ed-rpc ,(current-thread-id) ,tag - ,(symbol-name-for-emacs fn) - ,@args)) - (wait-for-emacs-return tag))) - -(defun version () - (asdf:component-version (asdf:find-system :micros))) - -(defslimefun connection-info () - "Return a key-value list of the form: -\(&key PID STYLE LISP-IMPLEMENTATION MACHINE FEATURES PACKAGE VERSION) -PID: is the process-id of Lisp process (or nil, depending on the STYLE) -STYLE: the communication style -LISP-IMPLEMENTATION: a list (&key TYPE NAME VERSION) -FEATURES: a list of keywords -PACKAGE: a list (&key NAME PROMPT) -VERSION: the protocol version" - (let ((c *emacs-connection*)) - (setq *slime-features* *features*) - `(:pid ,(getpid) :style ,(connection.communication-style c) - :encoding (:coding-systems - ,(loop for cs in '("utf-8-unix" "iso-latin-1-unix") - when (find-external-format cs) collect cs)) - :lisp-implementation (:type ,(lisp-implementation-type) - :name ,(lisp-implementation-type-name) - :version ,(lisp-implementation-version) - :program ,(lisp-implementation-program)) - :machine (:instance ,(machine-instance) - :type ,(machine-type) - :version ,(machine-version)) - :features ,(features-for-emacs) - :modules ,*modules* - :package (:name ,(package-name *package*) - :prompt ,(package-string-for-prompt *package*)) - :version ,(version)))) - -(defun debug-on-swank-error () - (assert (eq *debug-on-swank-protocol-error* *debug-swank-backend*)) - *debug-on-swank-protocol-error*) - -(defun (setf debug-on-swank-error) (new-value) - (setf *debug-on-swank-protocol-error* new-value) - (setf *debug-swank-backend* new-value)) - -(defslimefun toggle-debug-on-swank-error () - (setf (debug-on-swank-error) (not (debug-on-swank-error)))) - - -;;;; Reading and printing - -(define-special *buffer-package* - "Package corresponding to slime-buffer-package. - -EVAL-FOR-EMACS binds *buffer-package*. Strings originating from a slime -buffer are best read in this package. See also FROM-STRING and TO-STRING.") - -(define-special *buffer-readtable* - "Readtable associated with the current buffer") - -(defmacro with-buffer-syntax ((&optional package) &body body) - "Execute BODY with appropriate *package* and *readtable* bindings. - -This should be used for code that is conceptionally executed in an -Emacs buffer." - `(call-with-buffer-syntax ,package (lambda () ,@body))) - -(defun call-with-buffer-syntax (package fun) - (let ((*package* (if package - (guess-buffer-package package) - *buffer-package*))) - ;; Don't shadow *readtable* unnecessarily because that prevents - ;; the user from assigning to it. - (if (eq *readtable* *buffer-readtable*) - (call-with-syntax-hooks fun) - (let ((*readtable* *buffer-readtable*)) - (call-with-syntax-hooks fun))))) - -(defmacro without-printing-errors ((&key object stream - (msg "<>")) - &body body) - "Catches errors during evaluation of BODY and prints MSG instead." - `(handler-case (progn ,@body) - (serious-condition () - ,(cond ((and stream object) - (let ((gstream (gensym "STREAM+"))) - `(let ((,gstream ,stream)) - (print-unreadable-object (,object ,gstream :type t - :identity t) - (write-string ,msg ,gstream))))) - (stream - `(write-string ,msg ,stream)) - (object - `(with-output-to-string (s) - (print-unreadable-object (,object s :type t :identity t) - (write-string ,msg s)))) - (t msg))))) - -(defun to-string (object) - "Write OBJECT in the *BUFFER-PACKAGE*. -The result may not be readable. Handles problems with PRINT-OBJECT methods -gracefully." - (with-buffer-syntax () - (let ((*print-readably* nil)) - (without-printing-errors (:object object :stream nil) - (prin1-to-string object))))) - -(defun from-string (string) - "Read string in the *BUFFER-PACKAGE*" - (with-buffer-syntax () - (let ((*read-suppress* nil)) - (values (read-from-string string))))) - -(defun parse-string (string package) - "Read STRING in PACKAGE." - (with-buffer-syntax (package) - (let ((*read-suppress* nil)) - (read-from-string string)))) - -;; FIXME: deal with #\| etc. hard to do portably. -(defun tokenize-symbol (string) - "STRING is interpreted as the string representation of a symbol -and is tokenized accordingly. The result is returned in three -values: The package identifier part, the actual symbol identifier -part, and a flag if the STRING represents a symbol that is -internal to the package identifier part. (Notice that the flag is -also true with an empty package identifier part, as the STRING is -considered to represent a symbol internal to some current package.)" - (let ((package (let ((pos (position #\: string))) - (if pos (subseq string 0 pos) nil))) - (symbol (let ((pos (position #\: string :from-end t))) - (if pos (subseq string (1+ pos)) string))) - (internp (not (= (count #\: string) 1)))) - (values symbol package internp))) - -(defun tokenize-symbol-thoroughly (string) - "This version of TOKENIZE-SYMBOL handles escape characters." - (let ((package nil) - (token (make-array (length string) :element-type 'character - :fill-pointer 0)) - (backslash nil) - (vertical nil) - (internp nil)) - (loop for char across string do - (cond - (backslash - (vector-push-extend char token) - (setq backslash nil)) - ((char= char #\\) ; Quotes next character, even within |...| - (setq backslash t)) - ((char= char #\|) - (setq vertical (not vertical))) - (vertical - (vector-push-extend char token)) - ((char= char #\:) - (cond ((and package internp) - (return-from tokenize-symbol-thoroughly)) - (package - (setq internp t)) - (t - (setq package token - token (make-array (length string) - :element-type 'character - :fill-pointer 0))))) - (t - (vector-push-extend (casify-char char) token)))) - (unless vertical - (values token package (or (not package) internp))))) - -(defun untokenize-symbol (package-name internal-p symbol-name) - "The inverse of TOKENIZE-SYMBOL. - - (untokenize-symbol \"quux\" nil \"foo\") ==> \"quux:foo\" - (untokenize-symbol \"quux\" t \"foo\") ==> \"quux::foo\" - (untokenize-symbol nil nil \"foo\") ==> \"foo\" -" - (cond ((not package-name) symbol-name) - (internal-p (cat package-name "::" symbol-name)) - (t (cat package-name ":" symbol-name)))) - -(defun casify-char (char) - "Convert CHAR accoring to readtable-case." - (ecase (readtable-case *readtable*) - (:preserve char) - (:upcase (char-upcase char)) - (:downcase (char-downcase char)) - (:invert (if (upper-case-p char) - (char-downcase char) - (char-upcase char))))) - - -(defun find-symbol-with-status (symbol-name status - &optional (package *package*)) - (multiple-value-bind (symbol flag) (find-symbol symbol-name package) - (if (and flag (eq flag status)) - (values symbol flag) - (values nil nil)))) - -(defun parse-symbol (string &optional (package *package*)) - "Find the symbol named STRING. -Return the symbol and a flag indicating whether the symbols was found." - (multiple-value-bind (sname pname internalp) - (tokenize-symbol-thoroughly string) - (when sname - (let ((package (cond ((string= pname "") keyword-package) - (pname (find-package pname)) - (t package)))) - (if package - (multiple-value-bind (symbol flag) - (if internalp - (find-symbol sname package) - (find-symbol-with-status sname ':external package)) - (values symbol flag sname package)) - (values nil nil nil nil)))))) - -(defun parse-symbol-or-lose (string &optional (package *package*)) - (multiple-value-bind (symbol status) (parse-symbol string package) - (if status - (values symbol status) - (error "Unknown symbol: ~A [in ~A]" string package)))) - -(defun parse-package (string) - "Find the package named STRING. -Return the package or nil." - ;; STRING comes usually from a (in-package STRING) form. - (ignore-errors - (find-package (let ((*package* *swank-io-package*)) - (read-from-string string))))) - -(defun unparse-name (string) - "Print the name STRING according to the current printer settings." - ;; this is intended for package or symbol names - (subseq (prin1-to-string (make-symbol string)) 2)) - -(defun guess-package (string) - "Guess which package corresponds to STRING. -Return nil if no package matches." - (when string - (or (find-package string) - (parse-package string) - (if (find #\! string) ; for SBCL - (guess-package (substitute #\- #\! string)))))) - -(defvar *readtable-alist* (default-readtable-alist) - "An alist mapping package names to readtables.") - -(defun guess-buffer-readtable (package-name) - (let ((package (guess-package package-name))) - (or (and package - (cdr (assoc (package-name package) *readtable-alist* - :test #'string=))) - *readtable*))) - - -;;;; Evaluation - -(defvar *pending-continuations* '() - "List of continuations for Emacs. (thread local)") - -(defvar *request-thread-pair-table* (make-hash-table)) - -(defun get-thread-id (request-id) - (sb-ext:with-locked-hash-table (*request-thread-pair-table*) - (gethash request-id *request-thread-pair-table*))) - -(defun guess-buffer-package (string) - "Return a package for STRING. -Fall back to the current if no such package exists." - (or (and string (guess-package string)) - *package*)) - -(defun eval-for-emacs (form buffer-package id) - "Bind *BUFFER-PACKAGE* to BUFFER-PACKAGE and evaluate FORM. -Return the result to the continuation ID. -Errors are trapped and invoke our debugger." - (let (ok result condition) - (unwind-protect - (let ((*buffer-package* (guess-buffer-package buffer-package)) - (*buffer-readtable* (guess-buffer-readtable buffer-package)) - (*pending-continuations* (cons id *pending-continuations*))) - (sb-ext:with-locked-hash-table (*request-thread-pair-table*) - (setf (gethash id *request-thread-pair-table*) - (thread-id (current-thread)))) - (check-type *buffer-package* package) - (check-type *buffer-readtable* readtable) - ;; APPLY would be cleaner than EVAL. - ;; (setq result (apply (car form) (cdr form))) - (handler-bind ((t (lambda (c) (setf condition c)))) - (setq result (with-slime-interrupts (eval form)))) - (run-hook *pre-reply-hook*) - (setq ok t)) - (sb-ext:with-locked-hash-table (*request-thread-pair-table*) - (remhash id *request-thread-pair-table*)) - (send-to-emacs `(:return ,(current-thread) - ,(if ok - `(:ok ,result) - `(:abort ,(prin1-to-string condition))) - ,id))))) - -(defvar *echo-area-prefix* "=> " - "A prefix that `format-values-for-echo-area' should use.") - -(defun format-values-for-echo-area (values) - (with-buffer-syntax () - (let ((*print-readably* nil)) - (cond ((null values) "; No value") - ((and (integerp (car values)) (null (cdr values))) - (let ((i (car values))) - (format nil "~A~D (~a bit~:p, #x~X, #o~O, #b~B)" - *echo-area-prefix* - i (integer-length i) i i i))) - ((and (typep (car values) 'ratio) - (null (cdr values)) - (ignore-errors - ;; The ratio may be to large to be represented as a single float - (format nil "~A~D (~:*~f)" - *echo-area-prefix* - (car values))))) - (t (format nil "~a~{~S~^, ~}" *echo-area-prefix* values)))))) - -(defmacro values-to-string (values) - `(format-values-for-echo-area (multiple-value-list ,values))) - -(defslimefun interactive-eval (string) - (with-buffer-syntax () - (with-retry-restart (:msg "Retry SLIME interactive evaluation request.") - (let ((values (multiple-value-list (eval (from-string string))))) - (finish-output) - (format-values-for-echo-area values))))) - -(defslimefun eval-and-grab-output (string) - (with-buffer-syntax () - (with-retry-restart (:msg "Retry SLIME evaluation request.") - (let* ((s (make-string-output-stream)) - (*standard-output* s) - (values (multiple-value-list (eval (from-string string))))) - (list (get-output-stream-string s) - (format nil "~{~S~^~%~}" values)))))) - -(defun eval-region (string) - "Evaluate STRING. -Return the results of the last form as a list and as secondary value the -last form." - (with-input-from-string (stream string) - (let (- values) - (loop - (let ((form (read stream nil stream))) - (when (eq form stream) - (finish-output) - (return (values values -))) - (setq - form) - (setq values (multiple-value-list (eval form))) - (finish-output)))))) - -(defslimefun interactive-eval-region (string) - (with-buffer-syntax () - (with-retry-restart (:msg "Retry SLIME interactive evaluation request.") - (format-values-for-echo-area (eval-region string))))) - -(defslimefun re-evaluate-defvar (form) - (with-buffer-syntax () - (with-retry-restart (:msg "Retry SLIME evaluation request.") - (let ((form (read-from-string form))) - (destructuring-bind (dv name &optional value doc) form - (declare (ignore value doc)) - (assert (eq dv 'defvar)) - (makunbound name) - (prin1-to-string (eval form))))))) - -(defvar *swank-pprint-bindings* - `((*print-pretty* . t) - (*print-level* . nil) - (*print-length* . nil) - (*print-circle* . t) - (*print-gensym* . t) - (*print-readably* . nil)) - "A list of variables bindings during pretty printing. -Used by pprint-eval.") - -(defun swank-pprint (values) - "Bind some printer variables and pretty print each object in VALUES." - (with-buffer-syntax () - (with-bindings *swank-pprint-bindings* - (cond ((null values) "; No value") - (t (with-output-to-string (*standard-output*) - (dolist (o values) - (pprint o) - (terpri)))))))) - -(defslimefun pprint-eval (string) - (with-buffer-syntax () - (let* ((s (make-string-output-stream)) - (values - (let ((*standard-output* s) - (*trace-output* s)) - (multiple-value-list (eval (read-from-string string)))))) - (cat (get-output-stream-string s) - (swank-pprint values))))) - -(defslimefun set-package (name) - "Set *package* to the package named NAME. -Return the full package-name and the string to use in the prompt." - (let ((p (guess-package name))) - (assert (packagep p) nil "Package ~a doesn't exist." name) - (setq *package* p) - (list (package-name p) (package-string-for-prompt p)))) - -(defun cat (&rest strings) - "Concatenate all arguments and make the result a string." - (with-output-to-string (out) - (dolist (s strings) - (etypecase s - (string (write-string s out)) - (character (write-char s out)))))) - -(defun truncate-string (string width &optional ellipsis) - (let ((len (length string))) - (cond ((< len width) string) - (ellipsis (cat (subseq string 0 width) ellipsis)) - (t (subseq string 0 width))))) - -(defun call/truncated-output-to-string (length function - &optional (ellipsis "..")) - "Call FUNCTION with a new stream, return the output written to the stream. -If FUNCTION tries to write more than LENGTH characters, it will be -aborted and return immediately with the output written so far." - (let ((buffer (make-string (+ length (length ellipsis)))) - (fill-pointer 0)) - (block buffer-full - (flet ((write-output (string) - (let* ((free (- length fill-pointer)) - (count (min free (length string)))) - (replace buffer string :start1 fill-pointer :end2 count) - (incf fill-pointer count) - (when (> (length string) free) - (replace buffer ellipsis :start1 fill-pointer) - (return-from buffer-full buffer))))) - (let ((stream (make-output-stream #'write-output))) - (funcall function stream) - (finish-output stream) - (subseq buffer 0 fill-pointer)))))) - -(defmacro with-string-stream ((var &key length bindings) - &body body) - (cond ((and (not bindings) (not length)) - `(with-output-to-string (,var) . ,body)) - ((not bindings) - `(call/truncated-output-to-string - ,length (lambda (,var) . ,body))) - (t - `(with-bindings ,bindings - (with-string-stream (,var :length ,length) - . ,body))))) - -(defun to-line (object &optional width) - "Print OBJECT to a single line. Return the string." - (let ((width (or width 512))) - (without-printing-errors (:object object :stream nil) - (with-string-stream (stream :length width) - (write object :stream stream :right-margin width :lines 1))))) - -(defun escape-string (string stream &key length (map '((#\" . "\\\"") - (#\\ . "\\\\")))) - "Write STRING to STREAM surronded by double-quotes. -LENGTH -- if non-nil truncate output after LENGTH chars. -MAP -- rewrite the chars in STRING according to this alist." - (let ((limit (or length array-dimension-limit))) - (write-char #\" stream) - (loop for c across string - for i from 0 do - (when (= i limit) - (write-string "..." stream) - (return)) - (let ((probe (assoc c map))) - (cond (probe (write-string (cdr probe) stream)) - (t (write-char c stream))))) - (write-char #\" stream))) - - -;;;; Prompt - -;; FIXME: do we really need 45 lines of code just to figure out the -;; prompt? - -(defvar *canonical-package-nicknames* - `((:common-lisp-user . :cl-user)) - "Canonical package names to use instead of shortest name/nickname.") - -(defvar *auto-abbreviate-dotted-packages* t - "Abbreviate dotted package names to their last component if T.") - -(defun package-string-for-prompt (package) - "Return the shortest nickname (or canonical name) of PACKAGE." - (unparse-name - (or (canonical-package-nickname package) - (auto-abbreviated-package-name package) - (shortest-package-nickname package)))) - -(defun canonical-package-nickname (package) - "Return the canonical package nickname, if any, of PACKAGE." - (let ((name (cdr (assoc (package-name package) *canonical-package-nicknames* - :test #'string=)))) - (and name (string name)))) - -(defun auto-abbreviated-package-name (package) - "Return an abbreviated 'name' for PACKAGE. - -N.B. this is not an actual package name or nickname." - (when *auto-abbreviate-dotted-packages* - (loop with package-name = (package-name package) - with offset = nil - do (let ((last-dot-pos (position #\. package-name :end offset - :from-end t))) - (unless last-dot-pos - (return nil)) - ;; If a dot chunk contains only numbers, that chunk most - ;; likely represents a version number; so we collect the - ;; next chunks, too, until we find one with meat. - (let ((name (subseq package-name (1+ last-dot-pos) offset))) - (if (notevery #'digit-char-p name) - (return (subseq package-name (1+ last-dot-pos))) - (setq offset last-dot-pos))))))) - -(defun shortest-package-nickname (package) - "Return the shortest nickname of PACKAGE." - (loop for name in (cons (package-name package) (package-nicknames package)) - for shortest = name then (if (< (length name) (length shortest)) - name - shortest) - finally (return shortest))) - - - -(defslimefun ed-in-emacs (&optional what) - "Edit WHAT in Emacs. - -WHAT can be: - A pathname or a string, - A list (PATHNAME-OR-STRING &key LINE COLUMN POSITION), - A function name (symbol or cons), - NIL. " - (flet ((canonicalize-filename (filename) - (pathname-to-filename (or (probe-file filename) filename)))) - (let ((target - (etypecase what - (null nil) - ((or string pathname) - `(:filename ,(canonicalize-filename what))) - ((cons (or string pathname) *) - `(:filename ,(canonicalize-filename (car what)) ,@(cdr what))) - ((or symbol cons) - `(:function-name ,(prin1-to-string what)))))) - (cond (*emacs-connection* (send-oob-to-emacs `(:ed ,target))) - ((default-connection) - (with-connection ((default-connection)) - (send-oob-to-emacs `(:ed ,target)))) - (t (error "No connection")))))) - -(defslimefun inspect-in-emacs (what &key wait) - "Inspect WHAT in Emacs. If WAIT is true (default NIL) blocks until the -inspector has been closed in Emacs." - (flet ((send-it () - (let ((tag (when wait (make-tag))) - (thread (when wait (current-thread-id)))) - (with-buffer-syntax () - (reset-inspector) - (send-oob-to-emacs `(:inspect ,(inspect-object what) - ,thread - ,tag))) - (when wait - (wait-for-event `(:emacs-return ,tag result)))))) - (cond - (*emacs-connection* - (send-it)) - ((default-connection) - (with-connection ((default-connection)) - (send-it)))) - what)) - -(defslimefun value-for-editing (form) - "Return a readable value of FORM for editing in Emacs. -FORM is expected, but not required, to be SETF'able." - ;; FIXME: Can we check FORM for setfability? -luke (12/Mar/2005) - (with-buffer-syntax () - (let* ((value (eval (read-from-string form))) - (*print-length* nil)) - (prin1-to-string value)))) - -(defslimefun commit-edited-value (form value) - "Set the value of a setf'able FORM to VALUE. -FORM and VALUE are both strings from Emacs." - (with-buffer-syntax () - (eval `(setf ,(read-from-string form) - ,(read-from-string (concatenate 'string "`" value)))) - t)) - -(defun background-message (format-string &rest args) - "Display a message in Emacs' echo area. - -Use this function for informative messages only. The message may even -be dropped if we are too busy with other things." - (when *emacs-connection* - (send-to-emacs `(:background-message - ,(apply #'format nil format-string args))))) - -;; This is only used by the test suite. -(defun sleep-for (seconds) - "Sleep for at least SECONDS seconds. -This is just like cl:sleep but guarantees to sleep -at least SECONDS." - (let* ((start (get-internal-real-time)) - (end (+ start - (* seconds internal-time-units-per-second)))) - (loop - (let ((now (get-internal-real-time))) - (cond ((< end now) (return)) - (t (sleep (/ (- end now) - internal-time-units-per-second)))))))) - - -;;;; Debugger - -(defun invoke-slime-debugger (condition) - "Sends a message to Emacs declaring that the debugger has been entered, -then waits to handle further requests from Emacs. Eventually returns -after Emacs causes a restart to be invoked." - (without-slime-interrupts - (cond (*emacs-connection* - (debug-in-emacs condition)) - ((default-connection) - (with-connection ((default-connection)) - (debug-in-emacs condition)))))) - -(define-condition invoke-default-debugger () ()) - -(defun swank-debugger-hook (condition hook) - "Debugger function for binding *DEBUGGER-HOOK*." - (declare (ignore hook)) - (handler-case - (call-with-debugger-hook #'swank-debugger-hook - (lambda () (invoke-slime-debugger condition))) - (invoke-default-debugger () - (invoke-default-debugger condition)))) - -(defun invoke-default-debugger (condition) - (call-with-debugger-hook nil (lambda () (invoke-debugger condition)))) - -(defvar *global-debugger* t - "Non-nil means the Swank debugger hook will be installed globally.") - -(add-hook *new-connection-hook* 'install-debugger) -(defun install-debugger (connection) - (declare (ignore connection)) - (when *global-debugger* - (install-debugger-globally #'swank-debugger-hook))) - -;;;;; Debugger loop -;;; -;;; These variables are dynamically bound during debugging. -;;; -(defvar *swank-debugger-condition* nil - "The condition being debugged.") - -(defvar *sldb-level* 0 - "The current level of recursive debugging.") - -(defvar *sldb-initial-frames* 20 - "The initial number of backtrace frames to send to Emacs.") - -(defvar *sldb-restarts* nil - "The list of currenlty active restarts.") - -(defvar *sldb-stepping-p* nil - "True during execution of a step command.") - -(defun debug-in-emacs (condition) - (let ((*swank-debugger-condition* condition) - (*sldb-restarts* (compute-restarts condition)) - (*sldb-quit-restart* (and *sldb-quit-restart* - (find-restart *sldb-quit-restart*))) - (*package* (or (and (boundp '*buffer-package*) - (symbol-value '*buffer-package*)) - *package*)) - (*sldb-level* (1+ *sldb-level*)) - (*sldb-stepping-p* nil)) - (force-user-output) - (call-with-debugging-environment - (lambda () - (sldb-loop *sldb-level*))))) - -(defun sldb-loop (level) - (unwind-protect - (loop - (with-simple-restart (abort "Return to sldb level ~D." level) - (send-to-emacs - (list* :debug (current-thread-id) level - (debugger-info-for-emacs 0 *sldb-initial-frames*))) - (send-to-emacs - (list :debug-activate (current-thread-id) level nil)) - (loop - (handler-case - (dcase (wait-for-event - `(or (:emacs-rex . _) - (:sldb-return ,(1+ level)))) - ((:emacs-rex &rest args) (apply #'eval-for-emacs args)) - ((:sldb-return _) (declare (ignore _)) (return nil))) - (sldb-condition (c) - (handle-sldb-condition c)))))) - (send-to-emacs `(:debug-return - ,(current-thread-id) ,level ,*sldb-stepping-p*)) - (wait-for-event `(:sldb-return ,(1+ level)) t) ; clean event-queue - (when (> level 1) - (send-event (current-thread) `(:sldb-return ,level))))) - -(defun handle-sldb-condition (condition) - "Handle an internal debugger condition. -Rather than recursively debug the debugger (a dangerous idea!), these -conditions are simply reported." - (let ((real-condition (original-condition condition))) - (send-to-emacs `(:debug-condition ,(current-thread-id) - ,(princ-to-string real-condition))))) - -(defun %%condition-message (condition) - (let ((limit (ash 1 16))) - (with-string-stream (stream :length limit) - (handler-case - (let ((*print-readably* nil) - (*print-pretty* t) - (*print-right-margin* 65) - (*print-circle* t) - (*print-length* (or *print-length* 64)) - (*print-level* (or *print-level* 6)) - (*print-lines* (or *print-lines* limit))) - (print-condition condition stream)) - (serious-condition (c) - (ignore-errors - (with-standard-io-syntax - (let ((*print-readably* nil)) - (format stream "~&Error (~a) during printing: " (type-of c)) - (print-unreadable-object (condition stream :type t - :identity t)))))))))) - -(defun %condition-message (condition) - (string-trim #(#\newline #\space #\tab) - (%%condition-message condition))) - -(defvar *sldb-condition-printer* #'%condition-message - "Function called to print a condition to an SLDB buffer.") - -(defun safe-condition-message (condition) - "Print condition to a string, handling any errors during printing." - (funcall *sldb-condition-printer* condition)) - -(defun debugger-condition-for-emacs () - (list (safe-condition-message *swank-debugger-condition*) - (format nil " [Condition of type ~S]" - (type-of *swank-debugger-condition*)) - (condition-extras *swank-debugger-condition*))) - -(defun format-restarts-for-emacs () - "Return a list of restarts for *swank-debugger-condition* in a -format suitable for Emacs." - (let ((*print-right-margin* most-positive-fixnum)) - (loop for restart in *sldb-restarts* collect - (list (format nil "~:[~;*~]~a" - (eq restart *sldb-quit-restart*) - (restart-name restart)) - (with-output-to-string (stream) - (without-printing-errors (:object restart - :stream stream - :msg "<>") - (princ restart stream))))))) - -;;;;; SLDB entry points - -(defslimefun sldb-break-with-default-debugger (dont-unwind) - "Invoke the default debugger." - (cond (dont-unwind - (invoke-default-debugger *swank-debugger-condition*)) - (t - (signal 'invoke-default-debugger)))) - -(defslimefun backtrace (start end) - "Return a list ((I FRAME PLIST) ...) of frames from START to END. - -I is an integer, and can be used to reference the corresponding frame -from Emacs; FRAME is a string representation of an implementation's -frame." - (loop for frame in (compute-backtrace start end) - for i from start collect - (list* i (frame-to-string frame) - (ecase (frame-restartable-p frame) - ((nil) nil) - ((t) `((:restartable t))))))) - -(defun frame-to-string (frame) - (with-string-stream (stream :length (* (or *print-lines* 1) - (or *print-right-margin* 100)) - :bindings *backtrace-printer-bindings*) - (handler-case (print-frame frame stream) - (serious-condition () - (format stream "[error printing frame]"))))) - -(defslimefun debugger-info-for-emacs (start end) - "Return debugger state, with stack frames from START to END. -The result is a list: - (condition ({restart}*) ({stack-frame}*) (cont*)) -where - condition ::= (description type [extra]) - restart ::= (name description) - stack-frame ::= (number description [plist]) - extra ::= (:references and other random things) - cont ::= continutation - plist ::= (:restartable {nil | t | :unknown}) - -condition---a pair of strings: message, and type. If show-source is -not nil it is a frame number for which the source should be displayed. - -restart---a pair of strings: restart name, and description. - -stack-frame---a number from zero (the top), and a printed -representation of the frame's call. - -continutation---the id of a pending Emacs continuation. - -Below is an example return value. In this case the condition was a -division by zero (multi-line description), and only one frame is being -fetched (start=0, end=1). - - ((\"Arithmetic error DIVISION-BY-ZERO signalled. -Operation was KERNEL::DIVISION, operands (1 0).\" - \"[Condition of type DIVISION-BY-ZERO]\") - ((\"ABORT\" \"Return to Slime toplevel.\") - (\"ABORT\" \"Return to Top-Level.\")) - ((0 \"(KERNEL::INTEGER-/-INTEGER 1 0)\" (:restartable nil))) - (4))" - (list (debugger-condition-for-emacs) - (format-restarts-for-emacs) - (backtrace start end) - *pending-continuations*)) - -(defun nth-restart (index) - (nth index *sldb-restarts*)) - -(defslimefun invoke-nth-restart (index) - (let ((restart (nth-restart index))) - (when restart - (invoke-restart-interactively restart)))) - -(defslimefun sldb-abort () - (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name))) - -(defslimefun sldb-continue () - (invoke-restart (find 'continue *sldb-restarts* :key #'restart-name))) - -(defun coerce-to-condition (datum args) - (etypecase datum - (string (make-condition 'simple-error :format-control datum - :format-arguments args)) - (symbol (apply #'make-condition datum args)))) - -(defslimefun simple-break (&optional (datum "Interrupt from Emacs") &rest args) - (with-simple-restart (continue "Continue from break.") - (invoke-slime-debugger (coerce-to-condition datum args)))) - -;; FIXME: (last (compute-restarts)) looks dubious. -(defslimefun throw-to-toplevel () - "Invoke the ABORT-REQUEST restart abort an RPC from Emacs. -If we are not evaluating an RPC then ABORT instead." - (let ((restart (or (and *sldb-quit-restart* - (find-restart *sldb-quit-restart*)) - (car (last (compute-restarts)))))) - (cond (restart (invoke-restart restart)) - (t (format nil "Restart not active [~s]" *sldb-quit-restart*))))) - -(defslimefun invoke-nth-restart-for-emacs (sldb-level n) - "Invoke the Nth available restart. -SLDB-LEVEL is the debug level when the request was made. If this -has changed, ignore the request." - (when (= sldb-level *sldb-level*) - (invoke-nth-restart n))) - -(defun wrap-sldb-vars (form) - `(let ((*sldb-level* ,*sldb-level*)) - ,form)) - -(defun eval-in-frame-aux (frame string package print) - (let* ((form (wrap-sldb-vars (parse-string string package))) - (values (multiple-value-list (eval-in-frame form frame)))) - (with-buffer-syntax (package) - (funcall print values)))) - -(defslimefun eval-string-in-frame (string frame package) - (eval-in-frame-aux frame string package #'format-values-for-echo-area)) - -(defslimefun pprint-eval-string-in-frame (string frame package) - (eval-in-frame-aux frame string package #'swank-pprint)) - -(defslimefun frame-package-name (frame) - (let ((pkg (frame-package frame))) - (cond (pkg (package-name pkg)) - (t (with-buffer-syntax () (package-name *package*)))))) - -(defslimefun frame-locals-and-catch-tags (index) - "Return a list (LOCALS TAGS) for vars and catch tags in the frame INDEX. -LOCALS is a list of the form ((&key NAME ID VALUE) ...). -TAGS has is a list of strings." - (list (frame-locals-for-emacs index) - (mapcar #'to-string (frame-catch-tags index)))) - -(defun frame-locals-for-emacs (index) - (with-bindings *backtrace-printer-bindings* - (loop for var in (frame-locals index) collect - (destructuring-bind (&key name id value) var - (list :name (let ((*package* (or (frame-package index) *package*))) - (prin1-to-string name)) - :id id - :value (to-line value *print-right-margin*)))))) - -(defslimefun sldb-disassemble (index) - (with-output-to-string (*standard-output*) - (disassemble-frame index))) - -(defslimefun sldb-return-from-frame (index string) - (let ((form (from-string string))) - (to-string (multiple-value-list (return-from-frame index form))))) - -(defslimefun sldb-break (name) - (with-buffer-syntax () - (sldb-break-at-start (read-from-string name)))) - -(defmacro define-stepper-function (name backend-function-name) - `(defslimefun ,name (frame) - (cond ((sldb-stepper-condition-p *swank-debugger-condition*) - (setq *sldb-stepping-p* t) - (,backend-function-name)) - ((find-restart 'continue) - (activate-stepping frame) - (setq *sldb-stepping-p* t) - (continue)) - (t - (error "Not currently single-stepping, ~ -and no continue restart available."))))) - -(define-stepper-function sldb-step sldb-step-into) -(define-stepper-function sldb-next sldb-step-next) -(define-stepper-function sldb-out sldb-step-out) - -(defslimefun toggle-break-on-signals () - (setq *break-on-signals* (not *break-on-signals*)) - (format nil "*break-on-signals* = ~a" *break-on-signals*)) - -(defslimefun sdlb-print-condition () - (princ-to-string *swank-debugger-condition*)) - - -;;;; Compilation Commands. - -(defstruct (compilation-result (:type list)) - (type :compilation-result) - notes - (successp nil :type boolean) - (duration 0.0 :type float) - (loadp nil :type boolean) - (faslfile nil :type (or null string))) - -(defun measure-time-interval (fun) - "Call FUN and return the first return value and the elapsed time. -The time is measured in seconds." - (declare (type function fun)) - (let ((before (get-internal-real-time))) - (values - (funcall fun) - (/ (- (get-internal-real-time) before) - (coerce internal-time-units-per-second 'float))))) - -(defun make-compiler-note (condition) - "Make a compiler note data structure from a compiler-condition." - (declare (type compiler-condition condition)) - (list* :message (message condition) - :severity (severity condition) - :location (location condition) - :references (references condition) - (let ((s (source-context condition))) - (if s (list :source-context s))))) - -(defun collect-notes (function) - (let ((notes '())) - (multiple-value-bind (result seconds) - (handler-bind ((compiler-condition - (lambda (c) (push (make-compiler-note c) notes)))) - (measure-time-interval - (lambda () - ;; To report location of error-signaling toplevel forms - ;; for errors in EVAL-WHEN or during macroexpansion. - (restart-case (multiple-value-list (funcall function)) - (abort () :report "Abort compilation." (list nil)))))) - (destructuring-bind (successp &optional loadp faslfile) result - (let ((faslfile (etypecase faslfile - (null nil) - (pathname (pathname-to-filename faslfile))))) - (make-compilation-result :notes (reverse notes) - :duration seconds - :successp (if successp t) - :loadp (if loadp t) - :faslfile faslfile)))))) - -(defun swank-compile-file* (pathname load-p &rest options &key policy - &allow-other-keys) - (multiple-value-bind (output-pathname warnings? failure?) - (swank-compile-file pathname - (fasl-pathname pathname options) - nil - (or (guess-external-format pathname) - :default) - :policy policy) - (declare (ignore warnings?)) - (values t (not failure?) load-p output-pathname))) - -(defvar *compile-file-for-emacs-hook* '(swank-compile-file*)) - -(defslimefun compile-file-for-emacs (filename load-p &rest options) - "Compile FILENAME and, when LOAD-P, load the result. -Record compiler notes signalled as `compiler-condition's." - (with-buffer-syntax () - (collect-notes - (lambda () - (let ((pathname (filename-to-pathname filename)) - (*compile-print* nil) - (*compile-verbose* t)) - (loop for hook in *compile-file-for-emacs-hook* - do - (multiple-value-bind (tried success load? output-pathname) - (apply hook pathname load-p options) - (when tried - (return (values success load? output-pathname)))))))))) - -;; FIXME: now that *compile-file-for-emacs-hook* is there this is -;; redundant and confusing. -(defvar *fasl-pathname-function* nil - "In non-nil, use this function to compute the name for fasl-files.") - -(defun pathname-as-directory (pathname) - (append (pathname-directory pathname) - (when (pathname-name pathname) - (list (file-namestring pathname))))) - -(defun compile-file-output (file directory) - (make-pathname :directory (pathname-as-directory directory) - :defaults (compile-file-pathname file))) - -(defun fasl-pathname (input-file options) - (cond (*fasl-pathname-function* - (funcall *fasl-pathname-function* input-file options)) - ((getf options :fasl-directory) - (let ((dir (getf options :fasl-directory))) - (assert (char= (aref dir (1- (length dir))) #\/)) - (compile-file-output input-file dir))) - (t - (compile-file-pathname input-file)))) - -(defslimefun compile-string-for-emacs (string buffer position filename policy) - "Compile STRING (exerpted from BUFFER at POSITION). -Record compiler notes signalled as `compiler-condition's." - (let* ((offset (cadr (assoc :position position))) - (line-column (cdr (assoc :line position))) - (line (first line-column)) - (column (second line-column))) - (with-buffer-syntax () - (collect-notes - (lambda () - (let ((*compile-print* t) (*compile-verbose* nil)) - (swank-compile-string string - :buffer buffer - :position offset - :filename filename - :line line - :column column - :policy policy))))))) - -(defslimefun compile-multiple-strings-for-emacs (strings policy) - "Compile STRINGS (exerpted from BUFFER at POSITION). -Record compiler notes signalled as `compiler-condition's." - (loop for (string buffer package position filename) in strings collect - (collect-notes - (lambda () - (with-buffer-syntax (package) - (let ((*compile-print* t) (*compile-verbose* nil)) - (swank-compile-string string - :buffer buffer - :position position - :filename filename - :policy policy))))))) - -(defun file-newer-p (new-file old-file) - "Returns true if NEW-FILE is newer than OLD-FILE." - (> (file-write-date new-file) (file-write-date old-file))) - -(defun requires-compile-p (source-file) - (let ((fasl-file (probe-file (compile-file-pathname source-file)))) - (or (not fasl-file) - (file-newer-p source-file fasl-file)))) - -(defslimefun compile-file-if-needed (filename loadp) - (let ((pathname (filename-to-pathname filename))) - (cond ((requires-compile-p pathname) - (compile-file-for-emacs pathname loadp)) - (t - (collect-notes - (lambda () - (or (not loadp) - (load (compile-file-pathname pathname))))))))) - - -;;;; Loading - -(defslimefun load-file (filename) - (to-string (load (filename-to-pathname filename)))) - - -;;;; Macroexpansion - -(defvar *macroexpand-printer-bindings* - '((*print-circle* . nil) - (*print-pretty* . t) - (*print-escape* . t) - (*print-lines* . nil) - (*print-level* . nil) - (*print-length* . nil))) - -(defun apply-macro-expander (expander string) - (with-buffer-syntax () - (with-bindings *macroexpand-printer-bindings* - (prin1-to-string (funcall expander (from-string string)))))) - -(defslimefun swank-macroexpand-1 (string) - (apply-macro-expander #'macroexpand-1 string)) - -(defslimefun swank-macroexpand (string) - (apply-macro-expander #'macroexpand string)) - -(defslimefun swank-macroexpand-all (string) - (apply-macro-expander #'macroexpand-all string)) - -(defslimefun swank-compiler-macroexpand-1 (string) - (apply-macro-expander #'compiler-macroexpand-1 string)) - -(defslimefun swank-compiler-macroexpand (string) - (apply-macro-expander #'compiler-macroexpand string)) - -(defslimefun swank-expand-1 (string) - (apply-macro-expander #'expand-1 string)) - -(defslimefun swank-expand (string) - (apply-macro-expander #'expand string)) - -(defun expand-1 (form) - (multiple-value-bind (expansion expanded?) (macroexpand-1 form) - (if expanded? - (values expansion t) - (compiler-macroexpand-1 form)))) - -(defun expand (form) - (expand-repeatedly #'expand-1 form)) - -(defun expand-repeatedly (expander form) - (loop - (multiple-value-bind (expansion expanded?) (funcall expander form) - (unless expanded? (return expansion)) - (setq form expansion)))) - -(defslimefun swank-format-string-expand (string) - (apply-macro-expander #'format-string-expand string)) - -(defslimefun disassemble-form (form) - (with-buffer-syntax () - (with-output-to-string (*standard-output*) - (let ((*print-readably* nil)) - (disassemble (eval (read-from-string form))))))) - - -;;;; Simple completion - -(defslimefun simple-completions (prefix package) - "Return a list of completions for the string PREFIX." - (let ((strings (all-completions prefix package))) - (list strings (longest-common-prefix strings)))) - -(defun all-completions (prefix package) - (multiple-value-bind (name pname intern) (tokenize-symbol prefix) - (let* ((extern (and pname (not intern))) - (pkg (cond ((equal pname "") keyword-package) - ((not pname) (guess-buffer-package package)) - (t (guess-package pname)))) - (test (lambda (sym) (prefix-match-p name (symbol-name sym)))) - (syms (and pkg (matching-symbols pkg extern test))) - (strings (loop for sym in syms - for str = (unparse-symbol sym) - when (prefix-match-p name str) ; remove |Foo| - collect str))) - (format-completion-set strings intern pname)))) - -(defun matching-symbols (package external test) - (let ((test (if external - (lambda (s) - (and (symbol-external-p s package) - (funcall test s))) - test)) - (result '())) - (do-symbols (s package) - (when (funcall test s) - (push s result))) - (remove-duplicates result))) - -(defun unparse-symbol (symbol) - (let ((*print-case* (case (readtable-case *readtable*) - (:downcase :upcase) - (t :downcase)))) - (unparse-name (symbol-name symbol)))) - -(defun prefix-match-p (prefix string) - "Return true if PREFIX is a prefix of STRING." - (not (mismatch prefix string :end2 (min (length string) (length prefix)) - :test #'char-equal))) - -(defun longest-common-prefix (strings) - "Return the longest string that is a common prefix of STRINGS." - (if (null strings) - "" - (flet ((common-prefix (s1 s2) - (let ((diff-pos (mismatch s1 s2))) - (if diff-pos (subseq s1 0 diff-pos) s1)))) - (reduce #'common-prefix strings)))) - -(defun format-completion-set (strings internal-p package-name) - "Format a set of completion strings. -Returns a list of completions with package qualifiers if needed." - (mapcar (lambda (string) (untokenize-symbol package-name internal-p string)) - (sort strings #'string<))) - - -;;;; Simple arglist display - -(defslimefun operator-arglist (name package) - (ignore-errors - (let ((args (arglist (parse-symbol name (guess-buffer-package package))))) - (cond ((eq args :not-available) nil) - (t (princ-to-string (cons name args))))))) - - -;;;; Documentation - -(defslimefun apropos-list-for-emacs (name &optional external-only - case-sensitive package) - "Make an apropos search for Emacs. -The result is a list of property lists." - (let ((package (if package - (or (parse-package package) - (error "No such package: ~S" package))))) - ;; The MAPCAN will filter all uninteresting symbols, i.e. those - ;; who cannot be meaningfully described. - (mapcan (listify #'briefly-describe-symbol-for-emacs) - (sort (remove-duplicates - (apropos-symbols name external-only case-sensitive package)) - #'present-symbol-before-p)))) - -(defun briefly-describe-symbol-for-emacs (symbol) - "Return a property list describing SYMBOL. -Like `describe-symbol-for-emacs' but with at most one line per item." - (flet ((first-line (string) - (let ((pos (position #\newline string))) - (if (null pos) string (subseq string 0 pos))))) - (let ((desc (map-if #'stringp #'first-line - (describe-symbol-for-emacs symbol)))) - (if desc - (list* :designator (to-string symbol) desc))))) - -(defun map-if (test fn &rest lists) - "Like (mapcar FN . LISTS) but only call FN on objects satisfying TEST. -Example: -\(map-if #'oddp #'- '(1 2 3 4 5)) => (-1 2 -3 4 -5)" - (apply #'mapcar - (lambda (x) (if (funcall test x) (funcall fn x) x)) - lists)) - -(defun listify (f) - "Return a function like F, but which returns any non-null value -wrapped in a list." - (lambda (x) - (let ((y (funcall f x))) - (and y (list y))))) - -(defun present-symbol-before-p (x y) - "Return true if X belongs before Y in a printed summary of symbols. -Sorted alphabetically by package name and then symbol name, except -that symbols accessible in the current package go first." - (declare (type symbol x y)) - (flet ((accessible (s) - ;; Test breaks on NIL for package that does not inherit it - (eq (find-symbol (symbol-name s) *buffer-package*) s))) - (let ((ax (accessible x)) (ay (accessible y))) - (cond ((and ax ay) (string< (symbol-name x) (symbol-name y))) - (ax t) - (ay nil) - (t (let ((px (symbol-package x)) (py (symbol-package y))) - (if (eq px py) - (string< (symbol-name x) (symbol-name y)) - (string< (package-name px) (package-name py))))))))) - -(defun make-apropos-matcher (pattern case-sensitive) - (let ((chr= (if case-sensitive #'char= #'char-equal))) - (lambda (symbol) - (search pattern (string symbol) :test chr=)))) - -(defun apropos-symbols (string external-only case-sensitive package) - (let ((packages (or package (remove (find-package :keyword) - (list-all-packages)))) - (matcher (make-apropos-matcher string case-sensitive)) - (result)) - (with-package-iterator (next packages :external :internal) - (loop (multiple-value-bind (morep symbol) (next) - (cond ((not morep) (return)) - ((and (if external-only (symbol-external-p symbol) t) - (funcall matcher symbol)) - (push symbol result)))))) - result)) - -(defun call-with-describe-settings (fn) - (let ((*print-readably* nil)) - (funcall fn))) - -(defmacro with-describe-settings ((&rest _) &body body) - (declare (ignore _)) - `(call-with-describe-settings (lambda () ,@body))) - -(defun describe-to-string (object) - (with-describe-settings () - (with-output-to-string (*standard-output*) - (describe object)))) - -(defslimefun describe-symbol (symbol-name) - (with-buffer-syntax () - (describe-to-string (parse-symbol-or-lose symbol-name)))) - -(defslimefun describe-function (name) - (with-buffer-syntax () - (let ((symbol (parse-symbol-or-lose name))) - (describe-to-string (or (macro-function symbol) - (symbol-function symbol)))))) - -(defslimefun describe-definition-for-emacs (name kind) - (with-buffer-syntax () - (with-describe-settings () - (with-output-to-string (*standard-output*) - (describe-definition (parse-symbol-or-lose name) kind))))) - -(defslimefun documentation-symbol (symbol-name) - (with-buffer-syntax () - (multiple-value-bind (sym foundp) (parse-symbol symbol-name) - (if foundp - (let ((vdoc (documentation sym 'variable)) - (fdoc (documentation sym 'function))) - (with-output-to-string (string) - (format string "Documentation for the symbol ~a:~2%" sym) - (unless (or vdoc fdoc) - (format string "Not documented." )) - (when vdoc - (format string "Variable:~% ~a~2%" vdoc)) - (when fdoc - (format string "Function:~% Arglist: ~a~2% ~a" - (arglist sym) - fdoc)))) - (format nil "No such symbol, ~a." symbol-name))))) - - -;;;; Package Commands - -(defslimefun list-all-package-names (&optional nicknames) - "Return a list of all package names. -Include the nicknames if NICKNAMES is true." - (mapcar #'unparse-name - (if nicknames - (mapcan #'package-names (list-all-packages)) - (mapcar #'package-name (list-all-packages))))) - - -;;;; Tracing - -;; Use eval for the sake of portability... -(defun tracedp (fspec) - (member fspec (eval '(trace)))) - -(defvar *after-toggle-trace-hook* nil - "Hook called whenever a SPEC is traced or untraced. - -If non-nil, called with two arguments SPEC and TRACED-P." ) -(defslimefun swank-toggle-trace (spec-string) - (let* ((spec (from-string spec-string)) - (retval (cond ((consp spec) ; handle complicated cases in the backend - (toggle-trace spec)) - ((tracedp spec) - (eval `(untrace ,spec)) - (format nil "~S is now untraced." spec)) - (t - (eval `(trace ,spec)) - (format nil "~S is now traced." spec)))) - (traced-p (let* ((tosearch "is now traced.") - (start (- (length retval) - (length tosearch))) - (end (+ start (length tosearch)))) - (search tosearch (subseq retval start end)))) - (hook-msg (when *after-toggle-trace-hook* - (funcall *after-toggle-trace-hook* - spec - traced-p)))) - (if hook-msg - (format nil "~a~%(also ~a)" retval hook-msg) - retval))) - -(defslimefun untrace-all () - (untrace)) - - -;;;; Undefing - -(defslimefun undefine-function (fname-string) - (let ((fname (from-string fname-string))) - (format nil "~S" (fmakunbound fname)))) - -(defslimefun unintern-symbol (name package) - (let ((pkg (guess-package package))) - (cond ((not pkg) (format nil "No such package: ~s" package)) - (t - (multiple-value-bind (sym found) (parse-symbol name pkg) - (case found - ((nil) (format nil "~s not in package ~s" name package)) - (t - (unintern sym pkg) - (format nil "Uninterned symbol: ~s" sym)))))))) - -(defslimefun swank-delete-package (package-name) - (let ((pkg (or (guess-package package-name) - (error "No such package: ~s" package-name)))) - (delete-package pkg) - nil)) - - -;;;; Profiling - -(defun profiledp (fspec) - (member fspec (profiled-functions))) - -(defslimefun toggle-profile-fdefinition (fname-string) - (let ((fname (from-string fname-string))) - (cond ((profiledp fname) - (unprofile fname) - (format nil "~S is now unprofiled." fname)) - (t - (profile fname) - (format nil "~S is now profiled." fname))))) - -(defslimefun profile-by-substring (substring package) - (let ((count 0)) - (flet ((maybe-profile (symbol) - (when (and (fboundp symbol) - (not (profiledp symbol)) - (search substring (symbol-name symbol) :test #'equalp)) - (handler-case (progn - (profile symbol) - (incf count)) - (error (condition) - (warn "~a" condition)))))) - (if package - (do-symbols (symbol (parse-package package)) - (maybe-profile symbol)) - (do-all-symbols (symbol) - (maybe-profile symbol)))) - (format nil "~a function~:p ~:*~[are~;is~:;are~] now profiled" count))) - -(defslimefun swank-profile-package (package-name callersp methodsp) - (let ((pkg (or (guess-package package-name) - (error "Not a valid package name: ~s" package-name)))) - (check-type callersp boolean) - (check-type methodsp boolean) - (profile-package pkg callersp methodsp))) - - -;;;; Source Locations - -(defslimefun find-definition-for-thing (thing) - (find-source-location thing)) - -(defslimefun find-source-location-for-emacs (spec) - (find-source-location (value-spec-ref spec))) - -(defun value-spec-ref (spec) - (dcase spec - ((:string string package) - (with-buffer-syntax (package) - (eval (read-from-string string)))) - ((:inspector part) - (inspector-nth-part part)) - ((:sldb frame var) - (frame-var-value frame var)))) - -(defvar *find-definitions-right-trim* ",:.>") -(defvar *find-definitions-left-trim* "#:<") - -(defun find-definitions-find-symbol-or-package (name) - (flet ((do-find (name) - (multiple-value-bind (symbol found name) - (with-buffer-syntax () - (parse-symbol name)) - (cond (found - (return-from find-definitions-find-symbol-or-package - (values symbol found))) - ;; Packages are not named by symbols, so - ;; not-interned symbols can refer to packages - ((find-package name) - (return-from find-definitions-find-symbol-or-package - (values (make-symbol name) t))))))) - (do-find name) - (do-find (string-right-trim *find-definitions-right-trim* name)) - (do-find (string-left-trim *find-definitions-left-trim* name)) - (do-find (string-left-trim *find-definitions-left-trim* - (string-right-trim - *find-definitions-right-trim* name))) - ;; Not exactly robust - (when (and (eql (search "(setf " name :test #'char-equal) 0) - (char= (char name (1- (length name))) #\))) - (multiple-value-bind (symbol found) - (with-buffer-syntax () - (parse-symbol (subseq name (length "(setf ") - (1- (length name))))) - (when found - (values `(setf ,symbol) t)))))) - -(defslimefun find-definitions-for-emacs (name) - "Return a list ((DSPEC LOCATION) ...) of definitions for NAME. -DSPEC is a string and LOCATION a source location. NAME is a string." - (multiple-value-bind (symbol found) - (find-definitions-find-symbol-or-package name) - (when found - (mapcar #'xref>elisp (find-definitions symbol))))) - -;;; Generic function so contribs can extend it. -(defgeneric xref-doit (type thing) - (:method (type thing) - (declare (ignore type thing)) - :not-implemented)) - -(macrolet ((define-xref-action (xref-type handler) - `(defmethod xref-doit ((type (eql ,xref-type)) thing) - (declare (ignorable type)) - (funcall ,handler thing)))) - (define-xref-action :calls #'who-calls) - (define-xref-action :calls-who #'calls-who) - (define-xref-action :references #'who-references) - (define-xref-action :binds #'who-binds) - (define-xref-action :sets #'who-sets) - (define-xref-action :macroexpands #'who-macroexpands) - (define-xref-action :specializes #'who-specializes) - (define-xref-action :callers #'list-callers) - (define-xref-action :callees #'list-callees)) - -(defslimefun xref (type name) - (multiple-value-bind (sexp error) (ignore-errors (from-string name)) - (unless error - (let ((xrefs (xref-doit type sexp))) - (if (eq xrefs :not-implemented) - :not-implemented - (mapcar #'xref>elisp xrefs)))))) - -(defslimefun xrefs (types name) - (loop for type in types - for xrefs = (xref type name) - when (and (not (eq :not-implemented xrefs)) - (not (null xrefs))) - collect (cons type xrefs))) - -(defun xref>elisp (xref) - (destructuring-bind (name loc) xref - (list (to-string name) loc))) - - -;;;;; Lazy lists - -(defstruct (lcons (:constructor %lcons (car %cdr)) - (:predicate lcons?)) - car - (%cdr nil :type (or null lcons function)) - (forced? nil)) - -(defmacro lcons (car cdr) - `(%lcons ,car (lambda () ,cdr))) - -(defmacro lcons* (car cdr &rest more) - (cond ((null more) `(lcons ,car ,cdr)) - (t `(lcons ,car (lcons* ,cdr ,@more))))) - -(defun lcons-cdr (lcons) - (with-struct* (lcons- @ lcons) - (cond ((@ forced?) - (@ %cdr)) - (t - (let ((value (funcall (@ %cdr)))) - (setf (@ forced?) t - (@ %cdr) value)))))) - -(defun llist-range (llist start end) - (llist-take (llist-skip llist start) (- end start))) - -(defun llist-skip (lcons index) - (do ((i 0 (1+ i)) - (l lcons (lcons-cdr l))) - ((or (= i index) (null l)) - l))) - -(defun llist-take (lcons count) - (let ((result '())) - (do ((i 0 (1+ i)) - (l lcons (lcons-cdr l))) - ((or (= i count) - (null l))) - (push (lcons-car l) result)) - (nreverse result))) - -(defun iline (label value) - `(:line ,label ,value)) - - -;;;; Inspecting - -(defvar *inspector-verbose* nil) - -(defvar *inspector-printer-bindings* - '((*print-lines* . 1) - (*print-right-margin* . 75) - (*print-pretty* . t) - (*print-readably* . nil))) - -(defvar *inspector-verbose-printer-bindings* - '((*print-escape* . t) - (*print-circle* . t) - (*print-array* . nil))) - -(defstruct inspector-state) -(defstruct (istate (:conc-name istate.) (:include inspector-state)) - object - (verbose *inspector-verbose*) - (parts (make-array 10 :adjustable t :fill-pointer 0)) - (actions (make-array 10 :adjustable t :fill-pointer 0)) - metadata-plist - content - next previous) - -(defvar *istate* nil) -(defvar *inspector-history*) - -(defun reset-inspector () - (setq *istate* nil - *inspector-history* (make-array 10 :adjustable t :fill-pointer 0))) - -(defslimefun init-inspector (string) - (with-buffer-syntax () - (with-retry-restart (:msg "Retry SLIME inspection request.") - (reset-inspector) - (inspect-object (eval (read-from-string string)))))) - -(defun ensure-istate-metadata (o indicator default) - (with-struct (istate. object metadata-plist) *istate* - (assert (eq object o)) - (let ((data (getf metadata-plist indicator default))) - (setf (getf metadata-plist indicator) data) - data))) - -(defun inspect-object (o) - (let* ((prev *istate*) - (istate (make-istate :object o :previous prev - :verbose (cond (prev (istate.verbose prev)) - (t *inspector-verbose*))))) - (setq *istate* istate) - (setf (istate.content istate) (emacs-inspect/istate istate)) - (unless (find o *inspector-history*) - (vector-push-extend o *inspector-history*)) - (let ((previous (istate.previous istate))) - (if previous (setf (istate.next previous) istate))) - (istate>elisp istate))) - -(defun emacs-inspect/istate (istate) - (with-bindings (if (istate.verbose istate) - *inspector-verbose-printer-bindings* - *inspector-printer-bindings*) - (emacs-inspect (istate.object istate)))) - -(defun istate>elisp (istate) - (list :title (prepare-title istate) - :id (assign-index (istate.object istate) (istate.parts istate)) - :content (prepare-range istate 0 500))) - -(defun prepare-title (istate) - (if (istate.verbose istate) - (with-bindings *inspector-verbose-printer-bindings* - (to-string (istate.object istate))) - (with-string-stream (stream :length 200 - :bindings *inspector-printer-bindings*) - (print-unreadable-object - ((istate.object istate) stream :type t :identity t))))) - -(defun prepare-range (istate start end) - (let* ((range (content-range (istate.content istate) start end)) - (ps (loop for part in range append (prepare-part part istate)))) - (list ps - (if (< (length ps) (- end start)) - (+ start (length ps)) - (+ end 1000)) - start end))) - -(defun prepare-part (part istate) - (let ((newline '#.(string #\newline))) - (etypecase part - (string (list part)) - (cons (dcase part - ((:newline) (list newline)) - ((:value obj &optional str) - (list (value-part obj str (istate.parts istate)))) - ((:label &rest strs) - (list (list :label (apply #'cat (mapcar #'string strs))))) - ((:action label lambda &key (refreshp t)) - (list (action-part label lambda refreshp - (istate.actions istate)))) - ((:line label value) - (list (princ-to-string label) ": " - (value-part value nil (istate.parts istate)) - newline))))))) - -(defun value-part (object string parts) - (list :value - (or string (print-part-to-string object)) - (assign-index object parts))) - -(defun action-part (label lambda refreshp actions) - (list :action label (assign-index (list lambda refreshp) actions))) - -(defun assign-index (object vector) - (let ((index (fill-pointer vector))) - (vector-push-extend object vector) - index)) - -(defun print-part-to-string (value) - (let* ((*print-readably* nil) - (string (to-line value)) - (pos (position value *inspector-history*))) - (if pos - (format nil "@~D=~A" pos string) - string))) - -(defun content-range (list start end) - (typecase list - (list (let ((len (length list))) - (subseq list start (min len end)))) - (lcons (llist-range list start end)))) - -(defslimefun inspector-nth-part (index) - "Return the current inspector's INDEXth part. -The second value indicates if that part exists at all." - (let* ((parts (istate.parts *istate*)) - (foundp (< index (length parts)))) - (values (and foundp (aref parts index)) - foundp))) - -(defslimefun inspect-nth-part (index) - (with-buffer-syntax () - (inspect-object (inspector-nth-part index)))) - -(defslimefun inspector-range (from to) - (prepare-range *istate* from to)) - -(defslimefun inspector-call-nth-action (index &rest args) - (destructuring-bind (fun refreshp) (aref (istate.actions *istate*) index) - (apply fun args) - (if refreshp - (inspector-reinspect) - ;; tell emacs that we don't want to refresh the inspector buffer - nil))) - -(defslimefun inspector-pop () - "Inspect the previous object. -Return nil if there's no previous object." - (with-buffer-syntax () - (cond ((istate.previous *istate*) - (setq *istate* (istate.previous *istate*)) - (istate>elisp *istate*)) - (t nil)))) - -(defslimefun inspector-next () - "Inspect the next element in the history of inspected objects.." - (with-buffer-syntax () - (cond ((istate.next *istate*) - (setq *istate* (istate.next *istate*)) - (istate>elisp *istate*)) - (t nil)))) - -(defslimefun inspector-reinspect () - (let ((istate *istate*)) - (setf (istate.content istate) (emacs-inspect/istate istate)) - (istate>elisp istate))) - -(defslimefun inspector-toggle-verbose () - "Toggle verbosity of inspected object." - (setf (istate.verbose *istate*) (not (istate.verbose *istate*))) - (istate>elisp *istate*)) - -(defslimefun inspector-eval (string) - (let* ((obj (istate.object *istate*)) - (context (eval-context obj)) - (form (with-buffer-syntax ((cdr (assoc '*package* context))) - (read-from-string string))) - (ignorable (remove-if #'boundp (mapcar #'car context)))) - (to-string (eval `(let ((* ',obj) (- ',form) - . ,(loop for (var . val) in context - unless (constantp var) collect - `(,var ',val))) - (declare (ignorable . ,ignorable)) - ,form))))) - -(defslimefun inspector-history () - (with-output-to-string (out) - (let ((newest (loop for s = *istate* then next - for next = (istate.next s) - if (not next) return s))) - (format out "--- next/prev chain ---") - (loop for s = newest then (istate.previous s) while s do - (let ((val (istate.object s))) - (format out "~%~:[ ~; *~]@~d " - (eq s *istate*) - (position val *inspector-history*)) - (print-unreadable-object (val out :type t :identity t))))) - (format out "~%~%--- all visited objects ---") - (loop for val across *inspector-history* for i from 0 do - (format out "~%~2,' d " i) - (print-unreadable-object (val out :type t :identity t))))) - -(defslimefun quit-inspector () - (reset-inspector) - nil) - -(defslimefun describe-inspectee () - "Describe the currently inspected object." - (with-buffer-syntax () - (describe-to-string (istate.object *istate*)))) - -(defslimefun pprint-inspector-part (index) - "Pretty-print the currently inspected object." - (with-buffer-syntax () - (swank-pprint (list (inspector-nth-part index))))) - -(defslimefun inspect-in-frame (string index) - (with-buffer-syntax () - (with-retry-restart (:msg "Retry SLIME inspection request.") - (reset-inspector) - (inspect-object (eval-in-frame (from-string string) index))))) - -(defslimefun inspect-current-condition () - (with-buffer-syntax () - (reset-inspector) - (inspect-object *swank-debugger-condition*))) - -(defslimefun inspect-frame-var (frame var) - (with-buffer-syntax () - (reset-inspector) - (inspect-object (frame-var-value frame var)))) - -;;;;; Lists - -(defmethod emacs-inspect ((o cons)) - (if (listp (cdr o)) - (inspect-list o) - (inspect-cons o))) - -(defun inspect-cons (cons) - (label-value-line* - ('car (car cons)) - ('cdr (cdr cons)))) - -(defun inspect-list (list) - (multiple-value-bind (length tail) (safe-length list) - (flet ((frob (title list) - (list* title '(:newline) (inspect-list-aux list)))) - (cond ((not length) - (frob "A circular list:" - (cons (car list) - (ldiff (cdr list) list)))) - ((not tail) - (frob "A proper list:" list)) - (t - (frob "An improper list:" list)))))) - -(defun inspect-list-aux (list) - (loop for i from 0 for rest on list while (consp rest) append - (if (listp (cdr rest)) - (label-value-line i (car rest)) - (label-value-line* (i (car rest)) (:tail (cdr rest)))))) - -(defun safe-length (list) - "Similar to `list-length', but avoid errors on improper lists. -Return two values: the length of the list and the last cdr. -Return NIL if LIST is circular." - (do ((n 0 (+ n 2)) ;Counter. - (fast list (cddr fast)) ;Fast pointer: leaps by 2. - (slow list (cdr slow))) ;Slow pointer: leaps by 1. - (nil) - (cond ((null fast) (return (values n nil))) - ((not (consp fast)) (return (values n fast))) - ((null (cdr fast)) (return (values (1+ n) (cdr fast)))) - ((and (eq fast slow) (> n 0)) (return nil)) - ((not (consp (cdr fast))) (return (values (1+ n) (cdr fast))))))) - -;;;;; Hashtables - -(defun hash-table-to-alist (ht) - (let ((result '())) - (maphash (lambda (key value) - (setq result (acons key value result))) - ht) - result)) - -(defmethod emacs-inspect ((ht hash-table)) - (append - (label-value-line* - ("Count" (hash-table-count ht)) - ("Size" (hash-table-size ht)) - ("Test" (hash-table-test ht)) - ("Rehash size" (hash-table-rehash-size ht)) - ("Rehash threshold" (hash-table-rehash-threshold ht))) - (let ((weakness (hash-table-weakness ht))) - (when weakness - (label-value-line "Weakness:" weakness))) - (unless (zerop (hash-table-count ht)) - `((:action "[clear hashtable]" - ,(lambda () (clrhash ht))) (:newline) - "Contents: " (:newline))) - (let ((content (hash-table-to-alist ht))) - (cond ((every (lambda (x) (typep (first x) '(or string symbol))) content) - (setf content (sort content 'string< :key #'first))) - ((every (lambda (x) (typep (first x) 'real)) content) - (setf content (sort content '< :key #'first)))) - (loop for (key . value) in content appending - `((:value ,key) " = " (:value ,value) - " " (:action "[remove entry]" - ,(let ((key key)) - (lambda () (remhash key ht)))) - (:newline)))))) - -;;;;; Arrays - -(defmethod emacs-inspect ((array array)) - (lcons* - (iline "Dimensions" (array-dimensions array)) - (iline "Element type" (array-element-type array)) - (iline "Total size" (array-total-size array)) - (iline "Adjustable" (adjustable-array-p array)) - (iline "Fill pointer" (if (array-has-fill-pointer-p array) - (fill-pointer array))) - "Contents:" '(:newline) - (labels ((k (i max) - (cond ((= i max) '()) - (t (lcons (iline i (row-major-aref array i)) - (k (1+ i) max)))))) - (k 0 (array-total-size array))))) - -;;;;; Chars - -(defmethod emacs-inspect ((char character)) - (append - (label-value-line* - ("Char code" (char-code char)) - ("Lower cased" (char-downcase char)) - ("Upper cased" (char-upcase char))) - (if (get-macro-character char) - `("In the current readtable (" - (:value ,*readtable*) ") it is a macro character: " - (:value ,(get-macro-character char)))))) - -;;;; Thread listing - -(defvar *thread-list* () - "List of threads displayed in Emacs. We don't care a about -synchronization issues (yet). There can only be one thread listing at -a time.") - -(defslimefun list-threads () - "Return a list (LABELS (ID NAME STATUS ATTRS ...) ...). -LABELS is a list of attribute names and the remaining lists are the -corresponding attribute values per thread. -Example: - ((:id :name :status :priority) - (6 \"swank-indentation-cache-thread\" \"Semaphore timed wait\" 0) - (5 \"reader-thread\" \"Active\" 0) - (4 \"control-thread\" \"Semaphore timed wait\" 0) - (2 \"Swank Sentinel\" \"Semaphore timed wait\" 0) - (1 \"listener\" \"Active\" 0) - (0 \"Initial\" \"Sleep\" 0))" - (setq *thread-list* (all-threads)) - (when (and *emacs-connection* - (use-threads-p) - (equalp (thread-name (current-thread)) "worker")) - (setf *thread-list* (delete (current-thread) *thread-list*))) - (let* ((plist (thread-attributes (car *thread-list*))) - (labels (loop for (key) on plist by #'cddr - collect key))) - `((:id :name :status ,@labels) - ,@(loop for thread in *thread-list* - for name = (thread-name thread) - for attributes = (thread-attributes thread) - collect (list* (thread-id thread) - (string name) - (thread-status thread) - (loop for label in labels - collect (getf attributes label))))))) - -(defslimefun quit-thread-browser () - (setq *thread-list* nil)) - -(defun nth-thread (index) - (nth index *thread-list*)) - -(defslimefun debug-nth-thread (index) - (let ((connection *emacs-connection*)) - (queue-thread-interrupt - (nth-thread index) - (lambda () - (with-connection (connection) - (simple-break)))))) - -(defslimefun kill-nth-thread (index) - (kill-thread (nth-thread index))) - -(defslimefun start-swank-server-in-thread (index port-file-name) - "Interrupt the INDEXth thread and make it start a swank server. -The server port is written to PORT-FILE-NAME." - (interrupt-thread (nth-thread index) - (lambda () - (start-server port-file-name :style nil)))) - -;;;; Class browser - -(defun mop-helper (class-name fn) - (let ((class (find-class class-name nil))) - (if class - (mapcar (lambda (x) (to-string (class-name x))) - (funcall fn class))))) - -(defslimefun mop (type symbol-name) - "Return info about classes using mop. - - When type is: - :subclasses - return the list of subclasses of class. - :superclasses - return the list of superclasses of class." - (let ((symbol (parse-symbol symbol-name *buffer-package*))) - (ecase type - (:subclasses - (mop-helper symbol #'micros/mop:class-direct-subclasses)) - (:superclasses - (mop-helper symbol #'micros/mop:class-direct-superclasses))))) - - -;;;; Automatically synchronized state -;;; -;;; Here we add hooks to push updates of relevant information to -;;; Emacs. - -;;;;; *FEATURES* - -(defun sync-features-to-emacs () - "Update Emacs if any relevant Lisp state has changed." - ;; FIXME: *slime-features* should be connection-local - (unless (eq *slime-features* *features*) - (setq *slime-features* *features*) - (send-to-emacs (list :new-features (features-for-emacs))))) - -(defun features-for-emacs () - "Return `*slime-features*' in a format suitable to send it to Emacs." - *slime-features*) - -(add-hook *pre-reply-hook* 'sync-features-to-emacs) - - -;;;;; Indentation of macros -;;; -;;; This code decides how macros should be indented (based on their -;;; arglists) and tells Emacs. A per-connection cache is used to avoid -;;; sending redundant information to Emacs -- we just say what's -;;; changed since last time. -;;; -;;; The strategy is to scan all symbols, pick out the macros, and look -;;; for &body-arguments. - -(defvar *configure-emacs-indentation* t - "When true, automatically send indentation information to Emacs -after each command.") - -(defslimefun update-indentation-information () - (send-to-indentation-cache `(:update-indentation-information)) - nil) - -;; This function is for *PRE-REPLY-HOOK*. -(defun sync-indentation-to-emacs () - "Send any indentation updates to Emacs via CONNECTION." - (when *configure-emacs-indentation* - (send-to-indentation-cache `(:sync-indentation ,*buffer-package*)))) - -;; Send REQUEST to the cache. If we are single threaded perform the -;; request right away, otherwise delegate the request to the -;; indentation-cache-thread. -(defun send-to-indentation-cache (request) - (let ((c *emacs-connection*)) - (etypecase c - (singlethreaded-connection - (handle-indentation-cache-request c request)) - (multithreaded-connection - (without-slime-interrupts - (send (mconn.indentation-cache-thread c) request)))))) - -(defun indentation-cache-loop (connection) - (with-connection (connection) - (loop - (restart-case - (handle-indentation-cache-request connection (receive)) - (abort () - :report "Return to the indentation cache request handling loop."))))) - -(defun handle-indentation-cache-request (connection request) - (dcase request - ((:sync-indentation package) - (let ((fullp (need-full-indentation-update-p connection))) - (perform-indentation-update connection fullp package))) - ((:update-indentation-information) - (perform-indentation-update connection t nil)))) - -(defun need-full-indentation-update-p (connection) - "Return true if the whole indentation cache should be updated. -This is a heuristic to avoid scanning all symbols all the time: -instead, we only do a full scan if the set of packages has changed." - (set-difference (list-all-packages) - (connection.indentation-cache-packages connection))) - -(defun perform-indentation-update (connection force package) - "Update the indentation cache in CONNECTION and update Emacs. -If FORCE is true then start again without considering the old cache." - (let ((cache (connection.indentation-cache connection))) - (when force (clrhash cache)) - (let ((delta (update-indentation/delta-for-emacs cache force package))) - (setf (connection.indentation-cache-packages connection) - (list-all-packages)) - (unless (null delta) - (setf (connection.indentation-cache connection) cache) - (send-to-emacs (list :indentation-update delta)))))) - -(defun update-indentation/delta-for-emacs (cache force package) - "Update the cache and return the changes in a (SYMBOL INDENT PACKAGES) list. -If FORCE is true then check all symbols, otherwise only check symbols -belonging to PACKAGE." - (let ((alist '())) - (flet ((consider (symbol) - (let ((indent (symbol-indentation symbol))) - (when (or indent (gethash symbol cache)) - (unless (equal (gethash symbol cache) indent) - (setf (gethash symbol cache) indent) - (let ((pkgs (mapcar #'package-name - (symbol-packages symbol))) - (name (string-downcase symbol))) - (push (list name indent pkgs) alist))))))) - (cond (force - (do-all-symbols (symbol) - (consider symbol))) - ((package-name package) ; don't try to iterate over a - ; deleted package. - (do-symbols (symbol package) - (when (eq (symbol-package symbol) package) - (consider symbol))))) - alist))) - -(defun package-names (package) - "Return the name and all nicknames of PACKAGE in a fresh list." - (cons (package-name package) (copy-list (package-nicknames package)))) - -(defun symbol-packages (symbol) - "Return the packages where SYMBOL can be found." - (let ((string (string symbol))) - (loop for p in (list-all-packages) - when (eq symbol (find-symbol string p)) - collect p))) - -(defun cl-symbol-p (symbol) - "Is SYMBOL a symbol in the COMMON-LISP package?" - (eq (symbol-package symbol) cl-package)) - -(defun known-to-emacs-p (symbol) - "Return true if Emacs has special rules for indenting SYMBOL." - (cl-symbol-p symbol)) - -(defun symbol-indentation (symbol) - "Return a form describing the indentation of SYMBOL. -The form is to be used as the `common-lisp-indent-function' property -in Emacs." - (if (and (macro-function symbol) - (not (known-to-emacs-p symbol))) - (let ((arglist (arglist symbol))) - (etypecase arglist - ((member :not-available) - nil) - (list - (macro-indentation arglist)))) - nil)) - -(defun macro-indentation (arglist) - (if (well-formed-list-p arglist) - (position '&body (remove '&optional (clean-arglist arglist))) - nil)) - -(defun clean-arglist (arglist) - "Remove &whole, &enviroment, and &aux elements from ARGLIST." - (cond ((null arglist) '()) - ((member (car arglist) '(&whole &environment)) - (clean-arglist (cddr arglist))) - ((eq (car arglist) '&aux) - '()) - (t (cons (car arglist) (clean-arglist (cdr arglist)))))) - -(defun well-formed-list-p (list) - "Is LIST a proper list terminated by NIL?" - (typecase list - (null t) - (cons (well-formed-list-p (cdr list))) - (t nil))) - -(defun print-indentation-lossage (&optional (stream *standard-output*)) - "Return the list of symbols whose indentation styles collide incompatibly. -Collisions are caused because package information is ignored." - (let ((table (make-hash-table :test 'equal))) - (flet ((name (s) (string-downcase (symbol-name s)))) - (do-all-symbols (s) - (setf (gethash (name s) table) - (cons s (symbol-indentation s)))) - (let ((collisions '())) - (do-all-symbols (s) - (let* ((entry (gethash (name s) table)) - (owner (car entry)) - (indent (cdr entry))) - (unless (or (eq s owner) - (equal (symbol-indentation s) indent) - (and (not (fboundp s)) - (null (macro-function s)))) - (pushnew owner collisions) - (pushnew s collisions)))) - (if (null collisions) - (format stream "~&No worries!~%") - (format stream "~&Symbols with collisions:~%~{ ~S~%~}" - collisions)))))) - -;;; FIXME: it's too slow on CLASP right now, remove once it's fast enough. -#-clasp -(add-hook *pre-reply-hook* 'sync-indentation-to-emacs) - -(defun make-output-function-for-target (connection target) - "Create a function to send user output to a specific TARGET in Emacs." - (lambda (string) - (micros::with-connection (connection) - (with-simple-restart - (abort "Abort sending output to Emacs.") - (micros::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))) - - -;;;; Testing - -(defslimefun io-speed-test (&optional (n 1000) (m 1)) - (let* ((s *standard-output*) - (*trace-output* (make-broadcast-stream s *log-output*))) - (time (progn - (dotimes (i n) - (format s "~D abcdefghijklm~%" i) - (when (zerop (mod n m)) - (finish-output s))) - (finish-output s) - (when *emacs-connection* - (eval-in-emacs '(message "done."))))) - (terpri *trace-output*) - (finish-output *trace-output*) - nil)) - -(defslimefun flow-control-test (n delay) - (let ((stream (make-output-stream - (let ((conn *emacs-connection*)) - (lambda (string) - (declare (ignore string)) - (with-connection (conn) - (send-to-emacs `(:test-delay ,delay)))))))) - (dotimes (i n) - (print i stream) - (force-output stream) - (background-message "flow-control-test: ~d" i)))) - -;; Local Variables: -;; coding: latin-1-unix -;; indent-tabs-mode: nil -;; outline-regexp: ";;;;;*" -;; End: - -;;; swank.lisp ends here diff --git a/lib/micros/swank/backend.lisp b/lib/micros/swank/backend.lisp deleted file mode 100644 index 69a3cb4a2..000000000 --- a/lib/micros/swank/backend.lisp +++ /dev/null @@ -1,1583 +0,0 @@ -;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;*" -*- -;;; -;;; slime-backend.lisp --- SLIME backend interface. -;;; -;;; Created by James Bielman in 2003. Released into the public domain. -;;; -;;;; Frontmatter -;;; -;;; This file defines the functions that must be implemented -;;; separately for each Lisp. Each is declared as a generic function -;;; for which swank-.lisp provides methods. - -(in-package micros/backend) - - -;;;; Metacode - -(declaim (special micros:*communication-style*)) - -(defparameter *debug-swank-backend* nil - "If this is true, backends should not catch errors but enter the -debugger where appropriate. Also, they should not perform backtrace -magic but really show every frame including SWANK related ones.") - -(defparameter *interface-functions* '() - "The names of all interface functions.") - -(defparameter *unimplemented-interfaces* '() - "List of interface functions that are not implemented. -DEFINTERFACE adds to this list and DEFIMPLEMENTATION removes.") - -(defvar *log-output* nil) ; should be nil for image dumpers - -(defmacro definterface (name args documentation &rest default-body) - "Define an interface function for the backend to implement. -A function is defined with NAME, ARGS, and DOCUMENTATION. This -function first looks for a function to call in NAME's property list -that is indicated by 'IMPLEMENTATION; failing that, it looks for a -function indicated by 'DEFAULT. If neither is present, an error is -signaled. - -If a DEFAULT-BODY is supplied, then a function with the same body and -ARGS will be added to NAME's property list as the property indicated -by 'DEFAULT. - -Backends implement these functions using DEFIMPLEMENTATION." - (check-type documentation string "a documentation string") - (assert (every #'symbolp args) () - "Complex lambda-list not supported: ~S ~S" name args) - (labels ((gen-default-impl () - `(setf (get ',name 'default) (lambda ,args ,@default-body))) - (args-as-list (args) - (destructuring-bind (req opt key rest) (parse-lambda-list args) - `(,@req ,@opt - ,@(loop for k in key append `(,(kw k) ,k)) - ,@(or rest '(()))))) - (parse-lambda-list (args) - (parse args '(&optional &key &rest) - (make-array 4 :initial-element nil))) - (parse (args keywords vars) - (cond ((null args) - (reverse (map 'list #'reverse vars))) - ((member (car args) keywords) - (parse (cdr args) (cdr (member (car args) keywords)) vars)) - (t (push (car args) (aref vars (length keywords))) - (parse (cdr args) keywords vars)))) - (kw (s) (intern (string s) :keyword))) - `(progn - (defun ,name ,args - ,documentation - (let ((f (or (get ',name 'implementation) - (get ',name 'default)))) - (cond (f (apply f ,@(args-as-list args))) - (t (error "~S not implemented" ',name))))) - (pushnew ',name *interface-functions*) - ,(if (null default-body) - `(pushnew ',name *unimplemented-interfaces*) - (gen-default-impl)) - (eval-when (:compile-toplevel :load-toplevel :execute) - (export ',name :micros/backend)) - ',name))) - -(defmacro defimplementation (name args &body body) - (assert (every #'symbolp args) () - "Complex lambda-list not supported: ~S ~S" name args) - `(progn - (setf (get ',name 'implementation) - ;; For implicit BLOCK. FLET because of interplay w/ decls. - (flet ((,name ,args ,@body)) #',name)) - (if (member ',name *interface-functions*) - (setq *unimplemented-interfaces* - (remove ',name *unimplemented-interfaces*)) - (warn "DEFIMPLEMENTATION of undefined interface (~S)" ',name)) - ',name)) - -(defun warn-unimplemented-interfaces () - "Warn the user about unimplemented backend features. -The portable code calls this function at startup." - (let ((*print-pretty* t)) - (warn "These Swank interfaces are unimplemented:~% ~:<~{~A~^ ~:_~}~:>" - (list (sort (copy-list *unimplemented-interfaces*) #'string<))))) - -(defun import-to-swank-mop (symbol-list) - (dolist (sym symbol-list) - (let* ((swank-mop-sym (find-symbol (symbol-name sym) :micros/mop))) - (when swank-mop-sym - (unintern swank-mop-sym :micros/mop)) - (import sym :micros/mop) - (export sym :micros/mop)))) - -(defun import-swank-mop-symbols (package except) - "Import the mop symbols from PACKAGE to micros/mop. -EXCEPT is a list of symbol names which should be ignored." - (do-symbols (s :micros/mop) - (unless (member s except :test #'string=) - (let ((real-symbol (find-symbol (string s) package))) - (assert real-symbol () "Symbol ~A not found in package ~A" s package) - (unintern s :micros/mop) - (import real-symbol :micros/mop) - (export real-symbol :micros/mop))))) - -(definterface gray-package-name () - "Return a package-name that contains the Gray stream symbols. -This will be used like so: - (defpackage foo - (:import-from #.(gray-package-name) . #.*gray-stream-symbols*)") - - -;;;; Utilities - -(defmacro with-struct ((conc-name &rest names) obj &body body) - "Like with-slots but works only for structs." - (check-type conc-name symbol) - (flet ((reader (slot) - (intern (concatenate 'string - (symbol-name conc-name) - (symbol-name slot)) - (symbol-package conc-name)))) - (let ((tmp (gensym "OO-"))) - ` (let ((,tmp ,obj)) - (symbol-macrolet - ,(loop for name in names collect - (typecase name - (symbol `(,name (,(reader name) ,tmp))) - (cons `(,(first name) (,(reader (second name)) ,tmp))) - (t (error "Malformed syntax in WITH-STRUCT: ~A" name)))) - ,@body))))) - -(defmacro when-let ((var value) &body body) - `(let ((,var ,value)) - (when ,var ,@body))) - -(defun boolean-to-feature-expression (value) - "Converts a boolean VALUE to a form suitable for testing with #+." - (if value - '(:and) - '(:or))) - -(defun with-symbol (name package) - "Check if a symbol with a given NAME exists in PACKAGE and returns a -form suitable for testing with #+." - (boolean-to-feature-expression - (and (find-package package) - (find-symbol (string name) package)))) - -(defun choose-symbol (package name alt-package alt-name) - "If symbol package:name exists return that symbol, otherwise alt-package:alt-name. - Suitable for use with #." - (or (and (find-package package) - (find-symbol (string name) package)) - (find-symbol (string alt-name) alt-package))) - - -;;;; UFT8 - -(deftype octet () '(unsigned-byte 8)) -(deftype octets () '(simple-array octet (*))) - -;; Helper function. Decode the next N bytes starting from INDEX. -;; Return the decoded char and the new index. -(defun utf8-decode-aux (buffer index limit byte0 n) - (declare (type octets buffer) (fixnum index limit byte0 n)) - (if (< (- limit index) n) - (values nil index) - (do ((i 0 (1+ i)) - (code byte0 (let ((byte (aref buffer (+ index i)))) - (cond ((= (ldb (byte 2 6) byte) #b10) - (+ (ash code 6) (ldb (byte 6 0) byte))) - (t - #xFFFD))))) ;; Replacement_Character - ((= i n) - (values (cond ((<= code #xff) (code-char code)) - ((<= #xd800 code #xdfff) - (code-char #xFFFD)) ;; Replacement_Character - ((and (< code char-code-limit) - (code-char code))) - (t - (code-char #xFFFD))) ;; Replacement_Character - (+ index n)))))) - -;; Decode one character in BUFFER starting at INDEX. -;; Return 2 values: the character and the new index. -;; If there aren't enough bytes between INDEX and LIMIT return nil. -(defun utf8-decode (buffer index limit) - (declare (type octets buffer) (fixnum index limit)) - (if (= index limit) - (values nil index) - (let ((b (aref buffer index))) - (if (<= b #x7f) - (values (code-char b) (1+ index)) - (macrolet ((try (marker else) - (let* ((l (integer-length marker)) - (n (- l 2))) - `(if (= (ldb (byte ,l ,(- 8 l)) b) ,marker) - (utf8-decode-aux buffer (1+ index) limit - (ldb (byte ,(- 8 l) 0) b) - ,n) - ,else)))) - (try #b110 - (try #b1110 - (try #b11110 - (try #b111110 - (try #b1111110 - (error "Invalid encoding"))))))))))) - -;; Decode characters from BUFFER and write them to STRING. -;; Return 2 values: LASTINDEX and LASTSTART where -;; LASTINDEX is the last index in BUFFER that was not decoded -;; and LASTSTART is the last index in STRING not written. -(defun utf8-decode-into (buffer index limit string start end) - (declare (string string) (fixnum index limit start end) (type octets buffer)) - (loop - (cond ((= start end) - (return (values index start))) - (t - (multiple-value-bind (c i) (utf8-decode buffer index limit) - (cond (c - (setf (aref string start) c) - (setq index i) - (setq start (1+ start))) - (t - (return (values index start))))))))) - -(defun default-utf8-to-string (octets) - (let* ((limit (length octets)) - (str (make-string limit))) - (multiple-value-bind (i s) (utf8-decode-into octets 0 limit str 0 limit) - (if (= i limit) - (if (= limit s) - str - (adjust-array str s)) - (loop - (let ((end (+ (length str) (- limit i)))) - (setq str (adjust-array str end)) - (multiple-value-bind (i2 s2) - (utf8-decode-into octets i limit str s end) - (cond ((= i2 limit) - (return (adjust-array str s2))) - (t - (setq i i2) - (setq s s2)))))))))) - -(defmacro utf8-encode-aux (code buffer start end n) - `(cond ((< (- ,end ,start) ,n) - ,start) - (t - (setf (aref ,buffer ,start) - (dpb (ldb (byte ,(- 7 n) ,(* 6 (1- n))) ,code) - (byte ,(- 7 n) 0) - ,(dpb 0 (byte 1 (- 7 n)) #xff))) - ,@(loop for i from 0 upto (- n 2) collect - `(setf (aref ,buffer (+ ,start ,(- n 1 i))) - (dpb (ldb (byte 6 ,(* 6 i)) ,code) - (byte 6 0) - #b10111111))) - (+ ,start ,n)))) - -(defun %utf8-encode (code buffer start end) - (declare (type (unsigned-byte 31) code) (type octets buffer) - (type (and fixnum unsigned-byte) start end)) - (cond ((<= code #x7f) - (cond ((< start end) - (setf (aref buffer start) code) - (1+ start)) - (t start))) - ((<= code #x7ff) (utf8-encode-aux code buffer start end 2)) - ((<= #xd800 code #xdfff) - (%utf8-encode (code-char #xFFFD) ;; Replacement_Character - buffer start end)) - ((<= code #xffff) (utf8-encode-aux code buffer start end 3)) - ((<= code #x1fffff) (utf8-encode-aux code buffer start end 4)) - ((<= code #x3ffffff) (utf8-encode-aux code buffer start end 5)) - (t (utf8-encode-aux code buffer start end 6)))) - -(defun utf8-encode (char buffer start end) - (declare (type character char) (type octets buffer) - (type (and fixnum unsigned-byte) start end)) - (%utf8-encode (char-code char) buffer start end)) - -(defun utf8-encode-into (string start end buffer index limit) - (declare (string string) (type octets buffer) (fixnum start end index limit)) - (loop - (cond ((= start end) - (return (values start index))) - ((= index limit) - (return (values start index))) - (t - (let ((i2 (utf8-encode (char string start) buffer index limit))) - (cond ((= i2 index) - (return (values start index))) - (t - (setq index i2) - (incf start)))))))) - -(defun default-string-to-utf8 (string) - (let* ((len (length string)) - (b (make-array len :element-type 'octet))) - (multiple-value-bind (s i) (utf8-encode-into string 0 len b 0 len) - (if (= s len) - b - (loop - (let ((limit (+ (length b) (- len s)))) - (setq b (coerce (adjust-array b limit) 'octets)) - (multiple-value-bind (s2 i2) - (utf8-encode-into string s len b i limit) - (cond ((= s2 len) - (return (coerce (adjust-array b i2) 'octets))) - (t - (setq i i2) - (setq s s2)))))))))) - -(definterface string-to-utf8 (string) - "Convert the string STRING to a (simple-array (unsigned-byte 8))" - (default-string-to-utf8 string)) - -(definterface utf8-to-string (octets) - "Convert the (simple-array (unsigned-byte 8)) OCTETS to a string." - (default-utf8-to-string octets)) - - -;;;; TCP server - -(definterface create-socket (host port &key backlog) - "Create a listening TCP socket on interface HOST and port PORT. -BACKLOG queue length for incoming connections.") - -(definterface local-port (socket) - "Return the local port number of SOCKET.") - -(definterface close-socket (socket) - "Close the socket SOCKET.") - -(definterface accept-connection (socket &key external-format - buffering timeout) - "Accept a client connection on the listening socket SOCKET. -Return a stream for the new connection. -If EXTERNAL-FORMAT is nil return a binary stream -otherwise create a character stream. -BUFFERING can be one of: - nil ... no buffering - t ... enable buffering - :line ... enable buffering with automatic flushing on eol.") - -(definterface add-sigio-handler (socket fn) - "Call FN whenever SOCKET is readable.") - -(definterface remove-sigio-handlers (socket) - "Remove all sigio handlers for SOCKET.") - -(definterface add-fd-handler (socket fn) - "Call FN when Lisp is waiting for input and SOCKET is readable.") - -(definterface remove-fd-handlers (socket) - "Remove all fd-handlers for SOCKET.") - -(definterface preferred-communication-style () - "Return one of the symbols :spawn, :sigio, :fd-handler, or NIL." - nil) - -(definterface set-stream-timeout (stream timeout) - "Set the 'stream 'timeout. The timeout is either the real number - specifying the timeout in seconds or 'nil for no timeout." - (declare (ignore stream timeout)) - nil) - -;;; Base condition for networking errors. -(define-condition network-error (simple-error) ()) - -(definterface emacs-connected () - "Hook called when the first connection from Emacs is established. -Called from the INIT-FN of the socket server that accepts the -connection. - -This is intended for setting up extra context, e.g. to discover -that the calling thread is the one that interacts with Emacs." - nil) - - -;;;; Unix signals - -(defconstant +sigint+ 2) - -(definterface getpid () - "Return the (Unix) process ID of this superior Lisp.") - -(definterface install-sigint-handler (function) - "Call FUNCTION on SIGINT (instead of invoking the debugger). -Return old signal handler." - (declare (ignore function)) - nil) - -(definterface call-with-user-break-handler (handler function) - "Install the break handler HANDLER while executing FUNCTION." - (let ((old-handler (install-sigint-handler handler))) - (unwind-protect (funcall function) - (install-sigint-handler old-handler)))) - -(definterface quit-lisp () - "Exit the current lisp image.") - -(definterface lisp-implementation-type-name () - "Return a short name for the Lisp implementation." - (lisp-implementation-type)) - -(definterface lisp-implementation-program () - "Return the argv[0] of the running Lisp process, or NIL." - (let ((file (car (command-line-args)))) - (when (and file (probe-file file)) - (namestring (truename file))))) - -(definterface socket-fd (socket-stream) - "Return the file descriptor for SOCKET-STREAM.") - -(definterface make-fd-stream (fd external-format) - "Create a character stream for the file descriptor FD.") - -(definterface dup (fd) - "Duplicate a file descriptor. -If the syscall fails, signal a condition. -See dup(2).") - -(definterface exec-image (image-file args) - "Replace the current process with a new process image. -The new image is created by loading the previously dumped -core file IMAGE-FILE. -ARGS is a list of strings passed as arguments to -the new image. -This is thin wrapper around exec(3).") - -(definterface command-line-args () - "Return a list of strings as passed by the OS." - nil) - - -;; pathnames are sooo useless - -(definterface filename-to-pathname (filename) - "Return a pathname for FILENAME. -A filename in Emacs may for example contain asterisks which should not -be translated to wildcards." - (parse-namestring filename)) - -(definterface pathname-to-filename (pathname) - "Return the filename for PATHNAME." - (namestring pathname)) - -(definterface default-directory () - "Return the default directory." - (directory-namestring (truename *default-pathname-defaults*))) - -(definterface set-default-directory (directory) - "Set the default directory. -This is used to resolve filenames without directory component." - (setf *default-pathname-defaults* (truename (merge-pathnames directory))) - (default-directory)) - - -(definterface call-with-syntax-hooks (fn) - "Call FN with hooks to handle special syntax." - (funcall fn)) - -(definterface default-readtable-alist () - "Return a suitable initial value for micros:*READTABLE-ALIST*." - '()) - - -;;;; Packages - -(definterface package-local-nicknames (package) - "Returns an alist of (local-nickname . actual-package) describing the -nicknames local to the designated package." - (declare (ignore package)) - nil) - -(definterface find-locally-nicknamed-package (name base-package) - "Return the package whose local nickname in BASE-PACKAGE matches NAME. -Return NIL if local nicknames are not implemented or if there is no -such package." - (cdr (assoc name (package-local-nicknames base-package) :test #'string-equal))) - - -;;;; Compilation - -(definterface call-with-compilation-hooks (func) - "Call FUNC with hooks to record compiler conditions.") - -(defmacro with-compilation-hooks ((&rest ignore) &body body) - "Execute BODY as in CALL-WITH-COMPILATION-HOOKS." - (declare (ignore ignore)) - `(call-with-compilation-hooks (lambda () (progn ,@body)))) - -(definterface swank-compile-string (string &key buffer position filename - line column policy) - "Compile source from STRING. -During compilation, compiler conditions must be trapped and -resignalled as COMPILER-CONDITIONs. - -If supplied, BUFFER and POSITION specify the source location in Emacs. - -Additionally, if POSITION is supplied, it must be added to source -positions reported in compiler conditions. - -If FILENAME is specified it may be used by certain implementations to -rebind *DEFAULT-PATHNAME-DEFAULTS* which may improve the recording of -source information. - -If POLICY is supplied, and non-NIL, it may be used by certain -implementations to compile with optimization qualities of its -value. - -If LINE and COLUMN are supplied, and non-NIL, they may be used -by certain implementations as the line and column of the start of -the string in FILENAME. Both LINE and COLUMN are 1-based. - -Should return T on successful compilation, NIL otherwise. -") - -(definterface swank-compile-file (input-file output-file load-p - external-format - &key policy) - "Compile INPUT-FILE signalling COMPILE-CONDITIONs. -If LOAD-P is true, load the file after compilation. -EXTERNAL-FORMAT is a value returned by find-external-format or -:default. - -If POLICY is supplied, and non-NIL, it may be used by certain -implementations to compile with optimization qualities of its -value. - -Should return OUTPUT-TRUENAME, WARNINGS-P and FAILURE-p -like `compile-file'") - -(deftype severity () - '(member :error :read-error :warning :style-warning :note :redefinition)) - -;; Base condition type for compiler errors, warnings and notes. -(define-condition compiler-condition (condition) - ((original-condition - ;; The original condition thrown by the compiler if appropriate. - ;; May be NIL if a compiler does not report using conditions. - :type (or null condition) - :initarg :original-condition - :accessor original-condition) - - (severity :type severity - :initarg :severity - :accessor severity) - - (message :initarg :message - :accessor message) - - ;; Macro expansion history etc. which may be helpful in some cases - ;; but is often very verbose. - (source-context :initarg :source-context - :type (or null string) - :initform nil - :accessor source-context) - - (references :initarg :references - :initform nil - :accessor references) - - (location :initarg :location - :accessor location))) - -(definterface find-external-format (coding-system) - "Return a \"external file format designator\" for CODING-SYSTEM. -CODING-SYSTEM is Emacs-style coding system name (a string), -e.g. \"latin-1-unix\"." - (if (equal coding-system "iso-latin-1-unix") - :default - nil)) - -(definterface guess-external-format (pathname) - "Detect the external format for the file with name pathname. -Return nil if the file contains no special markers." - ;; Look for a Emacs-style -*- coding: ... -*- or Local Variable: section. - (with-open-file (s pathname :if-does-not-exist nil - :external-format (or (find-external-format "latin-1-unix") - :default)) - (if s - (or (let* ((line (read-line s nil)) - (p (search "-*-" line))) - (when p - (let* ((start (+ p (length "-*-"))) - (end (search "-*-" line :start2 start))) - (when end - (%search-coding line start end))))) - (let* ((len (file-length s)) - (buf (make-string (min len 3000)))) - (file-position s (- len (length buf))) - (read-sequence buf s) - (let ((start (search "Local Variables:" buf :from-end t)) - (end (search "End:" buf :from-end t))) - (and start end (< start end) - (%search-coding buf start end)))))))) - -(defun %search-coding (str start end) - (let ((p (search "coding:" str :start2 start :end2 end))) - (when p - (incf p (length "coding:")) - (loop while (and (< p end) - (member (aref str p) '(#\space #\tab))) - do (incf p)) - (let ((end (position-if (lambda (c) (find c '(#\space #\tab #\newline #\;))) - str :start p))) - (find-external-format (subseq str p end)))))) - - -;;;; Streams - -(definterface make-output-stream (write-string) - "Return a new character output stream. -The stream calls WRITE-STRING when output is ready.") - -(definterface make-input-stream (read-string) - "Return a new character input stream. -The stream calls READ-STRING when input is needed.") - -(defvar *auto-flush-interval* 0.2) - -(defun auto-flush-loop (stream interval &optional receive) - (loop - (when (not (and (open-stream-p stream) - (output-stream-p stream))) - (return nil)) - (force-output stream) - (when receive - (receive-if #'identity)) - (sleep interval))) - -(definterface make-auto-flush-thread (stream) - "Make an auto-flush thread" - (spawn (lambda () (auto-flush-loop stream *auto-flush-interval* nil)) - :name "auto-flush-thread")) - - -;;;; Documentation - -(definterface arglist (name) - "Return the lambda list for the symbol NAME. NAME can also be -a lisp function object, on lisps which support this. - -The result can be a list or the :not-available keyword if the -arglist cannot be determined." - (declare (ignore name)) - :not-available) - -(defgeneric declaration-arglist (decl-identifier) - (:documentation - "Return the argument list of the declaration specifier belonging to the -declaration identifier DECL-IDENTIFIER. If the arglist cannot be determined, -the keyword :NOT-AVAILABLE is returned. - -The different SWANK backends can specialize this generic function to -include implementation-dependend declaration specifiers, or to provide -additional information on the specifiers defined in ANSI Common Lisp.") - (:method (decl-identifier) - (case decl-identifier - (dynamic-extent '(&rest variables)) - (ignore '(&rest variables)) - (ignorable '(&rest variables)) - (special '(&rest variables)) - (inline '(&rest function-names)) - (notinline '(&rest function-names)) - (declaration '(&rest names)) - (optimize '(&any compilation-speed debug safety space speed)) - (type '(type-specifier &rest args)) - (ftype '(type-specifier &rest function-names)) - (otherwise - (flet ((typespec-p (symbol) - (member :type (describe-symbol-for-emacs symbol)))) - (cond ((and (symbolp decl-identifier) (typespec-p decl-identifier)) - '(&rest variables)) - ((and (listp decl-identifier) - (typespec-p (first decl-identifier))) - '(&rest variables)) - (t :not-available))))))) - -(defgeneric type-specifier-arglist (typespec-operator) - (:documentation - "Return the argument list of the type specifier belonging to -TYPESPEC-OPERATOR.. If the arglist cannot be determined, the keyword -:NOT-AVAILABLE is returned. - -The different SWANK backends can specialize this generic function to -include implementation-dependend declaration specifiers, or to provide -additional information on the specifiers defined in ANSI Common Lisp.") - (:method (typespec-operator) - (declare (special *type-specifier-arglists*)) ; defined at end of file. - (typecase typespec-operator - (symbol (or (cdr (assoc typespec-operator *type-specifier-arglists*)) - :not-available)) - (t :not-available)))) - -(definterface type-specifier-p (symbol) - "Determine if SYMBOL is a type-specifier." - (or (documentation symbol 'type) - (not (eq (type-specifier-arglist symbol) :not-available)))) - -(definterface function-name (function) - "Return the name of the function object FUNCTION. - -The result is either a symbol, a list, or NIL if no function name is -available." - (declare (ignore function)) - nil) - -(definterface valid-function-name-p (form) - "Is FORM syntactically valid to name a function? - If true, FBOUNDP should not signal a type-error for FORM." - (flet ((length=2 (list) - (and (not (null (cdr list))) (null (cddr list))))) - (or (symbolp form) - (and (consp form) (length=2 form) - (eq (first form) 'setf) (symbolp (second form)))))) - -(definterface macroexpand-all (form &optional env) - "Recursively expand all macros in FORM. -Return the resulting form.") - -(definterface compiler-macroexpand-1 (form &optional env) - "Call the compiler-macro for form. -If FORM is a function call for which a compiler-macro has been -defined, invoke the expander function using *macroexpand-hook* and -return the results and T. Otherwise, return the original form and -NIL." - (let ((fun (and (consp form) - (valid-function-name-p (car form)) - (compiler-macro-function (car form) env)))) - (if fun - (let ((result (funcall *macroexpand-hook* fun form env))) - (values result (not (eq result form)))) - (values form nil)))) - -(definterface compiler-macroexpand (form &optional env) - "Repetitively call `compiler-macroexpand-1'." - (labels ((frob (form expanded) - (multiple-value-bind (new-form newly-expanded) - (compiler-macroexpand-1 form env) - (if newly-expanded - (frob new-form t) - (values new-form expanded))))) - (frob form env))) - -(defmacro with-collected-macro-forms - ((forms &optional result) instrumented-form &body body) - "Collect macro forms by locally binding *MACROEXPAND-HOOK*. - -Evaluates INSTRUMENTED-FORM and collects any forms which undergo -macro-expansion into a list. Then evaluates BODY with FORMS bound to -the list of forms, and RESULT (optionally) bound to the value of -INSTRUMENTED-FORM." - (assert (and (symbolp forms) (not (null forms)))) - (assert (symbolp result)) - (let ((result-symbol (or result (gensym)))) - `(call-with-collected-macro-forms - (lambda (,forms ,result-symbol) - (declare (ignore ,@(and (not result) - `(,result-symbol)))) - ,@body) - (lambda () ,instrumented-form)))) - -(defun call-with-collected-macro-forms (body-fn instrumented-fn) - (let ((return-value nil) - (collected-forms '())) - (let* ((real-macroexpand-hook *macroexpand-hook*) - (*macroexpand-hook* - (lambda (macro-function form environment) - (let ((result (funcall real-macroexpand-hook - macro-function form environment))) - (unless (eq result form) - (push form collected-forms)) - result)))) - (setf return-value (funcall instrumented-fn))) - (funcall body-fn collected-forms return-value))) - -(definterface collect-macro-forms (form &optional env) - "Collect subforms of FORM which undergo (compiler-)macro expansion. -Returns two values: a list of macro forms and a list of compiler macro -forms." - (with-collected-macro-forms (macro-forms expansion) - (ignore-errors (macroexpand-all form env)) - (with-collected-macro-forms (compiler-macro-forms) - (handler-bind ((warning #'muffle-warning)) - (ignore-errors - (compile nil `(lambda () ,expansion)))) - (values macro-forms compiler-macro-forms)))) - -(definterface format-string-expand (control-string) - "Expand the format string CONTROL-STRING." - (macroexpand `(formatter ,control-string))) - -(definterface describe-symbol-for-emacs (symbol) - "Return a property list describing SYMBOL. - -The property list has an entry for each interesting aspect of the -symbol. The recognised keys are: - - :VARIABLE :FUNCTION :SETF :SPECIAL-OPERATOR :MACRO :COMPILER-MACRO - :TYPE :CLASS :ALIEN-TYPE :ALIEN-STRUCT :ALIEN-UNION :ALIEN-ENUM - -The value of each property is the corresponding documentation string, -or NIL (or the obsolete :NOT-DOCUMENTED). It is legal to include keys -not listed here (but slime-print-apropos in Emacs must know about -them). - -Properties should be included if and only if they are applicable to -the symbol. For example, only (and all) fbound symbols should include -the :FUNCTION property. - -Example: -\(describe-symbol-for-emacs 'vector) - => (:CLASS :NOT-DOCUMENTED - :TYPE :NOT-DOCUMENTED - :FUNCTION \"Constructs a simple-vector from the given objects.\")") - -(definterface describe-definition (name type) - "Describe the definition NAME of TYPE. -TYPE can be any value returned by DESCRIBE-SYMBOL-FOR-EMACS. - -Return a documentation string, or NIL if none is available.") - - -;;;; Debugging - -(definterface install-debugger-globally (function) - "Install FUNCTION as the debugger for all threads/processes. This -usually involves setting *DEBUGGER-HOOK* and, if the implementation -permits, hooking into BREAK as well." - (setq *debugger-hook* function)) - -(definterface call-with-debugging-environment (debugger-loop-fn) - "Call DEBUGGER-LOOP-FN in a suitable debugging environment. - -This function is called recursively at each debug level to invoke the -debugger loop. The purpose is to setup any necessary environment for -other debugger callbacks that will be called within the debugger loop. - -For example, this is a reasonable place to compute a backtrace, switch -to safe reader/printer settings, and so on.") - -(definterface call-with-debugger-hook (hook fun) - "Call FUN and use HOOK as debugger hook. HOOK can be NIL. - -HOOK should be called for both BREAK and INVOKE-DEBUGGER." - (let ((*debugger-hook* hook)) - (funcall fun))) - -(define-condition sldb-condition (condition) - ((original-condition - :initarg :original-condition - :accessor original-condition)) - (:report (lambda (condition stream) - (format stream "Condition in debugger code~@[: ~A~]" - (original-condition condition)))) - (:documentation - "Wrapper for conditions that should not be debugged. - -When a condition arises from the internals of the debugger, it is not -desirable to debug it -- we'd risk entering an endless loop trying to -debug the debugger! Instead, such conditions can be reported to the -user without (re)entering the debugger by wrapping them as -`sldb-condition's.")) - -;;; The following functions in this section are supposed to be called -;;; within the dynamic contour of CALL-WITH-DEBUGGING-ENVIRONMENT only. - -(definterface compute-backtrace (start end) - "Returns a backtrace of the condition currently being debugged, -that is an ordered list consisting of frames. ``Ordered list'' -means that an integer I can be mapped back to the i-th frame of this -backtrace. - -START and END are zero-based indices constraining the number of frames -returned. Frame zero is defined as the frame which invoked the -debugger. If END is nil, return the frames from START to the end of -the stack.") - -(definterface print-frame (frame stream) - "Print frame to stream.") - -(definterface frame-restartable-p (frame) - "Is the frame FRAME restartable?. -Return T if `restart-frame' can safely be called on the frame." - (declare (ignore frame)) - nil) - -(definterface frame-source-location (frame-number) - "Return the source location for the frame associated to FRAME-NUMBER.") - -(definterface frame-catch-tags (frame-number) - "Return a list of catch tags for being printed in a debugger stack -frame." - (declare (ignore frame-number)) - '()) - -(definterface frame-locals (frame-number) - "Return a list of ((&key NAME ID VALUE) ...) where each element of -the list represents a local variable in the stack frame associated to -FRAME-NUMBER. - -NAME, a symbol; the name of the local variable. - -ID, an integer; used as primary key for the local variable, unique -relatively to the frame under operation. - -value, an object; the value of the local variable.") - -(definterface frame-var-value (frame-number var-id) - "Return the value of the local variable associated to VAR-ID -relatively to the frame associated to FRAME-NUMBER.") - -(definterface disassemble-frame (frame-number) - "Disassemble the code for the FRAME-NUMBER. -The output should be written to standard output. -FRAME-NUMBER is a non-negative integer.") - -(definterface eval-in-frame (form frame-number) - "Evaluate a Lisp form in the lexical context of a stack frame -in the debugger. - -FRAME-NUMBER must be a positive integer with 0 indicating the -frame which invoked the debugger. - -The return value is the result of evaulating FORM in the -appropriate context.") - -(definterface frame-package (frame-number) - "Return the package corresponding to the frame at FRAME-NUMBER. -Return nil if the backend can't figure it out." - (declare (ignore frame-number)) - nil) - -(definterface frame-call (frame-number) - "Return a string representing a call to the entry point of a frame.") - -(definterface return-from-frame (frame-number form) - "Unwind the stack to the frame FRAME-NUMBER and return the value(s) -produced by evaluating FORM in the frame context to its caller. - -Execute any clean-up code from unwind-protect forms above the frame -during unwinding. - -Return a string describing the error if it's not possible to return -from the frame.") - -(definterface restart-frame (frame-number) - "Restart execution of the frame FRAME-NUMBER with the same arguments -as it was called originally.") - -(definterface print-condition (condition stream) - "Print a condition for display in SLDB." - (princ condition stream)) - -(definterface condition-extras (condition) - "Return a list of extra for the debugger. -The allowed elements are of the form: - (:SHOW-FRAME-SOURCE frame-number) - (:REFERENCES &rest refs) -" - (declare (ignore condition)) - '()) - -(definterface gdb-initial-commands () - "List of gdb commands supposed to be executed first for the - ATTACH-GDB restart." - nil) - -(definterface activate-stepping (frame-number) - "Prepare the frame FRAME-NUMBER for stepping.") - -(definterface sldb-break-on-return (frame-number) - "Set a breakpoint in the frame FRAME-NUMBER.") - -(definterface sldb-break-at-start (symbol) - "Set a breakpoint on the beginning of the function for SYMBOL.") - -(definterface sldb-stepper-condition-p (condition) - "Return true if SLDB was invoked due to a single-stepping condition, -false otherwise. " - (declare (ignore condition)) - nil) - -(definterface sldb-step-into () - "Step into the current single-stepper form.") - -(definterface sldb-step-next () - "Step to the next form in the current function.") - -(definterface sldb-step-out () - "Stop single-stepping temporarily, but resume it once the current function -returns.") - - -;;;; Definition finding - -(defstruct (location (:type list) - (:constructor make-location - (buffer position &optional hints))) - (type :location) - buffer position - ;; Hints is a property list optionally containing: - ;; :snippet SOURCE-TEXT - ;; This is a snippet of the actual source text at the start of - ;; the definition, which could be used in a text search. - hints) - -(defmacro converting-errors-to-error-location (&body body) - "Catches errors during BODY and converts them to an error location." - (let ((gblock (gensym "CONVERTING-ERRORS+"))) - `(block ,gblock - (handler-bind ((error - #'(lambda (e) - (if *debug-swank-backend* - nil ;decline - (return-from ,gblock - (make-error-location e)))))) - ,@body)))) - -(defun make-error-location (datum &rest args) - (cond ((typep datum 'condition) - `(:error ,(format nil "Error: ~A" datum))) - ((symbolp datum) - `(:error ,(format nil "Error: ~A" - (apply #'make-condition datum args)))) - (t - (assert (stringp datum)) - `(:error ,(apply #'format nil datum args))))) - -(definterface find-definitions (name) - "Return a list ((DSPEC LOCATION) ...) for NAME's definitions. - -NAME is a \"definition specifier\". - -DSPEC is a \"definition specifier\" describing the -definition, e.g., FOO or (METHOD FOO (STRING NUMBER)) or -\(DEFVAR FOO). - -LOCATION is the source location for the definition.") - -(definterface find-source-location (object) - "Returns the source location of OBJECT, or NIL. - -That is the source location of the underlying datastructure of -OBJECT. E.g. on a STANDARD-OBJECT, the source location of the -respective DEFCLASS definition is returned, on a STRUCTURE-CLASS the -respective DEFSTRUCT definition, and so on." - ;; This returns one source location and not a list of locations. It's - ;; supposed to return the location of the DEFGENERIC definition on - ;; #'SOME-GENERIC-FUNCTION. - (declare (ignore object)) - (make-error-location "FIND-SOURCE-LOCATION is not yet implemented on ~ - this implementation.")) - -(definterface buffer-first-change (filename) - "Called for effect the first time FILENAME's buffer is modified. -CMUCL/SBCL use this to cache the unmodified file and use the -unmodified text to improve the precision of source locations." - (declare (ignore filename)) - nil) - - - -;;;; XREF - -(definterface who-calls (function-name) - "Return the call sites of FUNCTION-NAME (a symbol). -The results is a list ((DSPEC LOCATION) ...)." - (declare (ignore function-name)) - :not-implemented) - -(definterface calls-who (function-name) - "Return the call sites of FUNCTION-NAME (a symbol). -The results is a list ((DSPEC LOCATION) ...)." - (declare (ignore function-name)) - :not-implemented) - -(definterface who-references (variable-name) - "Return the locations where VARIABLE-NAME (a symbol) is referenced. -See WHO-CALLS for a description of the return value." - (declare (ignore variable-name)) - :not-implemented) - -(definterface who-binds (variable-name) - "Return the locations where VARIABLE-NAME (a symbol) is bound. -See WHO-CALLS for a description of the return value." - (declare (ignore variable-name)) - :not-implemented) - -(definterface who-sets (variable-name) - "Return the locations where VARIABLE-NAME (a symbol) is set. -See WHO-CALLS for a description of the return value." - (declare (ignore variable-name)) - :not-implemented) - -(definterface who-macroexpands (macro-name) - "Return the locations where MACRO-NAME (a symbol) is expanded. -See WHO-CALLS for a description of the return value." - (declare (ignore macro-name)) - :not-implemented) - -(definterface who-specializes (class-name) - "Return the locations where CLASS-NAME (a symbol) is specialized. -See WHO-CALLS for a description of the return value." - (declare (ignore class-name)) - :not-implemented) - -;;; Simpler variants. - -(definterface list-callers (function-name) - "List the callers of FUNCTION-NAME. -This function is like WHO-CALLS except that it is expected to use -lower-level means. Whereas WHO-CALLS is usually implemented with -special compiler support, LIST-CALLERS is usually implemented by -groveling for constants in function objects throughout the heap. - -The return value is as for WHO-CALLS.") - -(definterface list-callees (function-name) - "List the functions called by FUNCTION-NAME. -See LIST-CALLERS for a description of the return value.") - - -;;;; Profiling - -;;; The following functions define a minimal profiling interface. - -(definterface profile (fname) - "Marks symbol FNAME for profiling.") - -(definterface profiled-functions () - "Returns a list of profiled functions.") - -(definterface unprofile (fname) - "Marks symbol FNAME as not profiled.") - -(definterface unprofile-all () - "Marks all currently profiled functions as not profiled." - (dolist (f (profiled-functions)) - (unprofile f))) - -(definterface profile-report () - "Prints profile report.") - -(definterface profile-reset () - "Resets profile counters.") - -(definterface profile-package (package callers-p methods) - "Wrap profiling code around all functions in PACKAGE. If a function -is already profiled, then unprofile and reprofile (useful to notice -function redefinition.) - -If CALLERS-P is T names have counts of the most common calling -functions recorded. - -When called with arguments :METHODS T, profile all methods of all -generic functions having names in the given package. Generic functions -themselves, that is, their dispatch functions, are left alone.") - - -;;;; Trace - -(definterface toggle-trace (spec) - "Toggle tracing of the function(s) given with SPEC. -SPEC can be: - (setf NAME) ; a setf function - (:defmethod NAME QUALIFIER... (SPECIALIZER...)) ; a specific method - (:defgeneric NAME) ; a generic function with all methods - (:call CALLER CALLEE) ; trace calls from CALLER to CALLEE. - (:labels TOPLEVEL LOCAL) - (:flet TOPLEVEL LOCAL) ") - - -;;;; Inspector - -(defgeneric emacs-inspect (object) - (:documentation - "Explain to Emacs how to inspect OBJECT. - -Returns a list specifying how to render the object for inspection. - -Every element of the list must be either a string, which will be -inserted into the buffer as is, or a list of the form: - - (:value object &optional format) - Render an inspectable - object. If format is provided it must be a string and will be - rendered in place of the value, otherwise use princ-to-string. - - (:newline) - Render a \\n - - (:action label lambda &key (refresh t)) - Render LABEL (a text - string) which when clicked will call LAMBDA. If REFRESH is - non-NIL the currently inspected object will be re-inspected - after calling the lambda. -")) - -(defmethod emacs-inspect ((object t)) - "Generic method for inspecting any kind of object. - -Since we don't know how to deal with OBJECT we simply dump the -output of CL:DESCRIBE." - `("Type: " (:value ,(type-of object)) (:newline) - "Don't know how to inspect the object, dumping output of CL:DESCRIBE:" - (:newline) (:newline) - ,(with-output-to-string (desc) (describe object desc)))) - -(definterface eval-context (object) - "Return a list of bindings corresponding to OBJECT's slots." - (declare (ignore object)) - '()) - -;;; Utilities for inspector methods. -;;; - -(defun label-value-line (label value &key (newline t)) - "Create a control list which prints \"LABEL: VALUE\" in the inspector. -If NEWLINE is non-NIL a `(:newline)' is added to the result." - (list* (princ-to-string label) ": " `(:value ,value) - (if newline '((:newline)) nil))) - -(defmacro label-value-line* (&rest label-values) - ` (append ,@(loop for (label value) in label-values - collect `(label-value-line ,label ,value)))) - -(definterface describe-primitive-type (object) - "Return a string describing the primitive type of object." - (declare (ignore object)) - "N/A") - - -;;;; Multithreading -;;; -;;; The default implementations are sufficient for non-multiprocessing -;;; implementations. - -(definterface initialize-multiprocessing (continuation) - "Initialize multiprocessing, if necessary and then invoke CONTINUATION. - -Depending on the impleimentaion, this function may never return." - (funcall continuation)) - -(definterface spawn (fn &key name) - "Create a new thread to call FN.") - -(definterface thread-id (thread) - "Return an Emacs-parsable object to identify THREAD. - -Ids should be comparable with equal, i.e.: - (equal (thread-id ) (thread-id )) <==> (eq )" - thread) - -(definterface find-thread (id) - "Return the thread for ID. -ID should be an id previously obtained with THREAD-ID. -Can return nil if the thread no longer exists." - (declare (ignore id)) - (current-thread)) - -(definterface thread-name (thread) - "Return the name of THREAD. -Thread names are short strings meaningful to the user. They do not -have to be unique." - (declare (ignore thread)) - "The One True Thread") - -(definterface thread-status (thread) - "Return a string describing THREAD's state." - (declare (ignore thread)) - "") - -(definterface thread-attributes (thread) - "Return a plist of implementation-dependent attributes for THREAD" - (declare (ignore thread)) - '()) - -(definterface current-thread () - "Return the currently executing thread." - 0) - -(definterface all-threads () - "Return a fresh list of all threads." - '()) - -(definterface thread-alive-p (thread) - "Test if THREAD is termintated." - (member thread (all-threads))) - -(definterface interrupt-thread (thread fn) - "Cause THREAD to execute FN.") - -(definterface kill-thread (thread) - "Terminate THREAD immediately. -Don't execute unwind-protected sections, don't raise conditions. -(Do not pass go, do not collect $200.)" - (declare (ignore thread)) - nil) - -(definterface send (thread object) - "Send OBJECT to thread THREAD." - (declare (ignore thread)) - object) - -(definterface receive (&optional timeout) - "Return the next message from current thread's mailbox." - (receive-if (constantly t) timeout)) - -(definterface receive-if (predicate &optional timeout) - "Return the first message satisfiying PREDICATE.") - -(definterface wake-thread (thread) - "Trigger a call to CHECK-SLIME-INTERRUPTS in THREAD without using -asynchronous interrupts." - (declare (ignore thread)) - ;; Doesn't have to implement this if RECEIVE-IF periodically calls - ;; CHECK-SLIME-INTERRUPTS, but that's energy inefficient - nil) - -(definterface register-thread (name thread) - "Associate the thread THREAD with the symbol NAME. -The thread can then be retrieved with `find-registered'. -If THREAD is nil delete the association." - (declare (ignore name thread)) - nil) - -(definterface find-registered (name) - "Find the thread that was registered for the symbol NAME. -Return nil if the no thread was registred or if the tread is dead." - (declare (ignore name)) - nil) - -(definterface set-default-initial-binding (var form) - "Initialize special variable VAR by default with FORM. - -Some implementations initialize certain variables in each newly -created thread. This function sets the form which is used to produce -the initial value." - (set var (eval form))) - -;; List of delayed interrupts. -;; This should only have thread-local bindings, so no init form. -(defvar *pending-slime-interrupts*) - -(defun check-slime-interrupts () - "Execute pending interrupts if any. -This should be called periodically in operations which -can take a long time to complete. -Return a boolean indicating whether any interrupts was processed." - (when (and (boundp '*pending-slime-interrupts*) - *pending-slime-interrupts*) - (funcall (pop *pending-slime-interrupts*)) - t)) - -(defvar *interrupt-queued-handler* nil - "Function to call on queued interrupts. -Interrupts get queued when an interrupt occurs while interrupt -handling is disabled. - -Backends can use this function to abort slow operations.") - -(definterface wait-for-input (streams &optional timeout) - "Wait for input on a list of streams. Return those that are ready. -STREAMS is a list of streams -TIMEOUT nil, t, or real number. If TIMEOUT is t, return those streams -which are ready (or have reached end-of-file) without waiting. -If TIMEOUT is a number and no streams is ready after TIMEOUT seconds, -return nil. - -Return :interrupt if an interrupt occurs while waiting." - (declare (ignore streams timeout)) - ;; Invoking the slime debugger will just endlessly loop. - (call-with-debugger-hook - nil - (lambda () - (error "~s not implemented. Check if ~s = ~s is supported by the implementation." - 'wait-for-input 'micros:*communication-style* micros:*communication-style*)))) - - -;;;; Locks - -;; Please use locks only in swank-gray.lisp. Locks are too low-level -;; for our taste. - -(definterface make-lock (&key name) - "Make a lock for thread synchronization. -Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time -but that thread may hold it more than once." - (declare (ignore name)) - :null-lock) - -(definterface call-with-lock-held (lock function) - "Call FUNCTION with LOCK held, queueing if necessary." - (declare (ignore lock) - (type function function)) - (funcall function)) - - -;;;; Weak datastructures - -(definterface make-weak-key-hash-table (&rest args) - "Like MAKE-HASH-TABLE, but weak w.r.t. the keys." - (apply #'make-hash-table args)) - -(definterface make-weak-value-hash-table (&rest args) - "Like MAKE-HASH-TABLE, but weak w.r.t. the values." - (apply #'make-hash-table args)) - -(definterface hash-table-weakness (hashtable) - "Return nil or one of :key :value :key-or-value :key-and-value" - (declare (ignore hashtable)) - nil) - - -;;;; Floating point - -(definterface float-nan-p (float) - "Return true if FLOAT is a NaN value (Not a Number)." - ;; When the float type implements IEEE-754 floats, two NaN values - ;; are never equal; when the implementation does not support NaN, - ;; the predicate should return false. An implementation can - ;; implement comparison with "unordered-signaling predicates", which - ;; emit floating point exceptions. - (handler-case (not (= float float)) - ;; Comparisons never signal an exception other than the invalid - ;; operation exception (5.11 Details of comparison predicates). - (floating-point-invalid-operation () t))) - -(definterface float-infinity-p (float) - "Return true if FLOAT is positive or negative infinity." - (not (< most-negative-long-float - float - most-positive-long-float))) - - -;;;; Character names - -(definterface character-completion-set (prefix matchp) - "Return a list of names of characters that match PREFIX." - ;; Handle the standard and semi-standard characters. - (loop for name in '("Newline" "Space" "Tab" "Page" "Rubout" - "Linefeed" "Return" "Backspace") - when (funcall matchp prefix name) - collect name)) - - -(defparameter *type-specifier-arglists* - '((and . (&rest type-specifiers)) - (array . (&optional element-type dimension-spec)) - (base-string . (&optional size)) - (bit-vector . (&optional size)) - (complex . (&optional type-specifier)) - (cons . (&optional car-typespec cdr-typespec)) - (double-float . (&optional lower-limit upper-limit)) - (eql . (object)) - (float . (&optional lower-limit upper-limit)) - (function . (&optional arg-typespec value-typespec)) - (integer . (&optional lower-limit upper-limit)) - (long-float . (&optional lower-limit upper-limit)) - (member . (&rest eql-objects)) - (mod . (n)) - (not . (type-specifier)) - (or . (&rest type-specifiers)) - (rational . (&optional lower-limit upper-limit)) - (real . (&optional lower-limit upper-limit)) - (satisfies . (predicate-symbol)) - (short-float . (&optional lower-limit upper-limit)) - (signed-byte . (&optional size)) - (simple-array . (&optional element-type dimension-spec)) - (simple-base-string . (&optional size)) - (simple-bit-vector . (&optional size)) - (simple-string . (&optional size)) - (single-float . (&optional lower-limit upper-limit)) - (simple-vector . (&optional size)) - (string . (&optional size)) - (unsigned-byte . (&optional size)) - (values . (&rest typespecs)) - (vector . (&optional element-type size)) - )) - -;;; Heap dumps - -(definterface save-image (filename &optional restart-function) - "Save a heap image to the file FILENAME. -RESTART-FUNCTION, if non-nil, should be called when the image is loaded.") - -(definterface background-save-image (filename &key restart-function - completion-function) - "Request saving a heap image to the file FILENAME. -RESTART-FUNCTION, if non-nil, should be called when the image is loaded. -COMPLETION-FUNCTION, if non-nil, should be called after saving the image.") - -(defun deinit-log-output () - ;; Can't hang on to an fd-stream from a previous session. - (setf *log-output* nil)) - - -;;;; Wrapping - -(definterface wrap (spec indicator &key before after replace) - "Intercept future calls to SPEC and surround them in callbacks. - -INDICATOR is a symbol identifying a particular wrapping, and is used -to differentiate between multiple wrappings. - -Implementations intercept calls to SPEC and call, in this order: - -* the BEFORE callback, if it's provided, with a single argument set to - the list of arguments passed to the intercepted call; - -* the original definition of SPEC recursively honouring any wrappings - previously established under different values of INDICATOR. If the - compatible function REPLACE is provided, call that instead. - -* the AFTER callback, if it's provided, with a single set to the list - of values returned by the previous call, or, if that call exited - non-locally, a single descriptive symbol, like :EXITED-NON-LOCALLY." - (declare (ignore indicator)) - (assert (symbolp spec) nil - "The default implementation for WRAP allows only simple names") - (assert (null (get spec 'slime-wrap)) nil - "The default implementation for WRAP allows a single wrapping") - (let* ((saved (symbol-function spec)) - (replacement (lambda (&rest args) - (let (retlist completed) - (unwind-protect - (progn - (when before - (funcall before args)) - (setq retlist (multiple-value-list - (apply (or replace - saved) args))) - (setq completed t) - (values-list retlist)) - (when after - (funcall after (if completed - retlist - :exited-non-locally)))))))) - (setf (get spec 'slime-wrap) (list saved replacement)) - (setf (symbol-function spec) replacement)) - spec) - -(definterface unwrap (spec indicator) - "Remove from SPEC any wrappings tagged with INDICATOR." - (if (wrapped-p spec indicator) - (setf (symbol-function spec) (first (get spec 'slime-wrap))) - (cerror "All right, so I did" - "Hmmm, ~a is not correctly wrapped, you probably redefined it" - spec)) - (setf (get spec 'slime-wrap) nil) - spec) - -(definterface wrapped-p (spec indicator) - "Returns true if SPEC is wrapped with INDICATOR." - (declare (ignore indicator)) - (and (symbolp spec) - (let ((prop-value (get spec 'slime-wrap))) - (cond ((and prop-value - (not (eq (second prop-value) - (symbol-function spec)))) - (warn "~a appears to be incorrectly wrapped" spec) - nil) - (prop-value t) - (t nil))))) diff --git a/lib/micros/swank/gray.lisp b/lib/micros/swank/gray.lisp deleted file mode 100644 index 5955db7dd..000000000 --- a/lib/micros/swank/gray.lisp +++ /dev/null @@ -1,219 +0,0 @@ -;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- -;;; -;;; swank-gray.lisp --- Gray stream based IO redirection. -;;; -;;; Created 2003 -;;; -;;; This code has been placed in the Public Domain. All warranties -;;; are disclaimed. -;;; - -(in-package micros/backend) - -#.(progn - (defvar *gray-stream-symbols* - '(fundamental-character-output-stream - stream-write-char - stream-write-string - stream-fresh-line - stream-force-output - stream-finish-output - - fundamental-character-input-stream - stream-read-char - stream-peek-char - stream-read-line - stream-listen - stream-unread-char - stream-clear-input - stream-line-column - stream-read-char-no-hang - - #+sbcl stream-file-position)) - nil) - -(defpackage micros/gray - (:use cl micros/backend) - (:import-from #.(gray-package-name) . #.*gray-stream-symbols*) - (:export . #.*gray-stream-symbols*)) - -(in-package micros/gray) - -(defclass slime-output-stream (fundamental-character-output-stream) - ((output-fn :initarg :output-fn) - (buffer :initform (make-string 8000)) - (fill-pointer :initform 0) - (column :initform 0) - (lock :initform (make-lock :name "buffer write lock")) - (flush-thread :initarg :flush-thread - :initform nil - :accessor flush-thread) - (flush-scheduled :initarg :flush-scheduled - :initform nil - :accessor flush-scheduled))) - -(defun maybe-schedule-flush (stream) - (when (and (flush-thread stream) - (not (flush-scheduled stream))) - (setf (flush-scheduled stream) t) - (send (flush-thread stream) t))) - -(defmacro with-slime-output-stream (stream &body body) - `(with-slots (lock output-fn buffer fill-pointer column) ,stream - (call-with-lock-held lock (lambda () ,@body)))) - -(defmethod stream-write-char ((stream slime-output-stream) char) - (with-slime-output-stream stream - (setf (schar buffer fill-pointer) char) - (incf fill-pointer) - (incf column) - (when (char= #\newline char) - (setf column 0)) - (if (= fill-pointer (length buffer)) - (finish-output stream) - (maybe-schedule-flush stream))) - char) - -(defmethod stream-write-string ((stream slime-output-stream) string - &optional start end) - (with-slime-output-stream stream - (let* ((start (or start 0)) - (end (or end (length string))) - (len (length buffer)) - (count (- end start)) - (free (- len fill-pointer))) - (when (>= count free) - (stream-finish-output stream)) - (cond ((< count len) - (replace buffer string :start1 fill-pointer - :start2 start :end2 end) - (incf fill-pointer count) - (maybe-schedule-flush stream)) - (t - (funcall output-fn (subseq string start end)))) - (let ((last-newline (position #\newline string :from-end t - :start start :end end))) - (setf column (if last-newline - (- end last-newline 1) - (+ column count)))))) - string) - -(defmethod stream-line-column ((stream slime-output-stream)) - (with-slime-output-stream stream column)) - -(defmethod stream-finish-output ((stream slime-output-stream)) - (with-slime-output-stream stream - (unless (zerop fill-pointer) - (funcall output-fn (subseq buffer 0 fill-pointer)) - (setf fill-pointer 0)) - (setf (flush-scheduled stream) nil)) - nil) - -#+(and sbcl sb-thread) -(defmethod stream-force-output :around ((stream slime-output-stream)) - ;; Workaround for deadlocks between the world-lock and auto-flush-thread - ;; buffer write lock. - ;; - ;; Another alternative would be to grab the world-lock here, but that's less - ;; future-proof, and could introduce other lock-ordering issues in the - ;; future. - (handler-case - (sb-sys:with-deadline (:seconds 0.1) - (call-next-method)) - (sb-sys:deadline-timeout () - nil))) - -(defmethod stream-force-output ((stream slime-output-stream)) - (stream-finish-output stream)) - -(defmethod stream-fresh-line ((stream slime-output-stream)) - (with-slime-output-stream stream - (cond ((zerop column) nil) - (t (terpri stream) t)))) - -#+sbcl -(defmethod stream-file-position ((stream slime-output-stream) &optional position) - (declare (ignore position)) - nil) - -(defclass slime-input-stream (fundamental-character-input-stream) - ((input-fn :initarg :input-fn) - (buffer :initform "") (index :initform 0) - (lock :initform (make-lock :name "buffer read lock")))) - -(defmethod stream-read-char ((s slime-input-stream)) - (call-with-lock-held - (slot-value s 'lock) - (lambda () - (with-slots (buffer index input-fn) s - (when (= index (length buffer)) - (let ((string (funcall input-fn))) - (cond ((zerop (length string)) - (return-from stream-read-char :eof)) - (t - (setf buffer string) - (setf index 0))))) - (assert (plusp (length buffer))) - (prog1 (aref buffer index) (incf index)))))) - -(defmethod stream-listen ((s slime-input-stream)) - (call-with-lock-held - (slot-value s 'lock) - (lambda () - (with-slots (buffer index) s - (< index (length buffer)))))) - -(defmethod stream-unread-char ((s slime-input-stream) char) - (call-with-lock-held - (slot-value s 'lock) - (lambda () - (with-slots (buffer index) s - (decf index) - (cond ((eql (aref buffer index) char) - (setf (aref buffer index) char)) - (t - (warn "stream-unread-char: ignoring ~S (expected ~S)" - char (aref buffer index))))))) - nil) - -(defmethod stream-clear-input ((s slime-input-stream)) - (call-with-lock-held - (slot-value s 'lock) - (lambda () - (with-slots (buffer index) s - (setf buffer "" - index 0)))) - nil) - -(defmethod stream-line-column ((s slime-input-stream)) - nil) - -(defmethod stream-read-char-no-hang ((s slime-input-stream)) - (call-with-lock-held - (slot-value s 'lock) - (lambda () - (with-slots (buffer index) s - (when (< index (length buffer)) - (prog1 (aref buffer index) (incf index))))))) - -#+sbcl -(defmethod stream-file-position ((stream slime-input-stream) &optional position) - (declare (ignore position)) - nil) - - -;;; - -(defimplementation make-auto-flush-thread (stream) - (if (typep stream 'slime-output-stream) - (setf (flush-thread stream) - (spawn (lambda () (auto-flush-loop stream 0.08 t)) - :name "auto-flush-thread")) - (spawn (lambda () (auto-flush-loop stream *auto-flush-interval*)) - :name "auto-flush-thread"))) - -(defimplementation make-output-stream (write-string) - (make-instance 'slime-output-stream :output-fn write-string)) - -(defimplementation make-input-stream (read-string) - (make-instance 'slime-input-stream :input-fn read-string)) diff --git a/lib/micros/swank/match.lisp b/lib/micros/swank/match.lisp deleted file mode 100644 index 941cd4d73..000000000 --- a/lib/micros/swank/match.lisp +++ /dev/null @@ -1,242 +0,0 @@ -;; -;; SELECT-MATCH macro (and IN macro) -;; -;; Copyright 1990 Stephen Adams -;; -;; You are free to copy, distribute and make derivative works of this -;; source provided that this copyright notice is displayed near the -;; beginning of the file. No liability is accepted for the -;; correctness or performance of the code. If you modify the code -;; please indicate this fact both at the place of modification and in -;; this copyright message. -;; -;; Stephen Adams -;; Department of Electronics and Computer Science -;; University of Southampton -;; SO9 5NH, UK -;; -;; sra@ecs.soton.ac.uk -;; - -;; -;; Synopsis: -;; -;; (select-match expression -;; (pattern action+)*) -;; -;; --- or --- -;; -;; (select-match expression -;; pattern => expression -;; pattern => expression -;; ...) -;; -;; pattern -> constant ;egs 1, #\x, #c(1.0 1.1) -;; | symbol ;matches anything -;; | 'anything ;must be EQUAL -;; | (pattern = pattern) ;both patterns must match -;; | (#'function pattern) ;predicate test -;; | (pattern . pattern) ;cons cell -;; - -;; Example -;; -;; (select-match item -;; (('if e1 e2 e3) 'if-then-else) ;(1) -;; ((#'oddp k) 'an-odd-integer) ;(2) -;; (((#'treep tree) = (hd . tl)) 'something-else) ;(3) -;; (other 'anything-else)) ;(4) -;; -;; Notes -;; -;; . Each pattern is tested in turn. The first match is taken. -;; -;; . If no pattern matches, an error is signalled. -;; -;; . Constant patterns (things X for which (CONSTANTP X) is true, i.e. -;; numbers, strings, characters, etc.) match things which are EQUAL. -;; -;; . Quoted patterns (which are CONSTANTP) are constants. -;; -;; . Symbols match anything. The symbol is bound to the matched item -;; for the execution of the actions. -;; For example, (SELECT-MATCH '(1 2 3) -;; (1 . X) => X) -;; returns (2 3) because X is bound to the cdr of the candidate. -;; -;; . The two pattern match (p1 = p2) can be used to name parts -;; of the matched structure. For example, (ALL = (HD . TL)) -;; matches a cons cell. ALL is bound to the cons cell, HD to its car -;; and TL to its tail. -;; -;; . A predicate test applies the predicate to the item being matched. -;; If the predicate returns NIL then the match fails. -;; If it returns truth, then the nested pattern is matched. This is -;; often just a symbol like K in the example. -;; -;; . Care should be taken with the domain values for predicate matches. -;; If, in the above eg, item is not an integer, an error would occur -;; during the test. A safer pattern would be -;; (#'integerp (#'oddp k)) -;; This would only test for oddness of the item was an integer. -;; -;; . A single symbol will match anything so it can be used as a default -;; case, like OTHER above. -;; - -(in-package micros/match) - -(defmacro match (expression &body patterns) - `(select-match ,expression ,@patterns)) - -(defmacro select-match (expression &rest patterns) - (let* ((do-let (not (atom expression))) - (key (if do-let (gensym) expression)) - (cbody (expand-select-patterns key patterns)) - (cform `(cond . ,cbody))) - (if do-let - `(let ((,key ,expression)) ,cform) - cform))) - -(defun expand-select-patterns (key patterns) - (if (eq (second patterns) '=>) - (expand-select-patterns-style-2 key patterns) - (expand-select-patterns-style-1 key patterns))) - -(defun expand-select-patterns-style-1 (key patterns) - (if (null patterns) - `((t (error "Case select pattern match failure on ~S" ,key))) - (let* ((pattern (caar patterns)) - (actions (cdar patterns)) - (rest (cdr patterns)) - (test (compile-select-test key pattern)) - (bindings (compile-select-bindings key pattern actions))) - `(,(if bindings `(,test (let ,bindings . ,actions)) - `(,test . ,actions)) - . ,(unless (eq test t) - (expand-select-patterns-style-1 key rest)))))) - -(defun expand-select-patterns-style-2 (key patterns) - (cond ((null patterns) - `((t (error "Case select pattern match failure on ~S" ,key)))) - (t (when (or (< (length patterns) 3) - (not (eq (second patterns) '=>))) - (error "Illegal patterns: ~S" patterns)) - (let* ((pattern (first patterns)) - (actions (list (third patterns))) - (rest (cdddr patterns)) - (test (compile-select-test key pattern)) - (bindings (compile-select-bindings key pattern actions))) - `(,(if bindings `(,test (let ,bindings . ,actions)) - `(,test . ,actions)) - . ,(unless (eq test t) - (expand-select-patterns-style-2 key rest))))))) - -(defun compile-select-test (key pattern) - (let ((tests (remove t (compile-select-tests key pattern)))) - (cond - ;; note AND does this anyway, but this allows us to tell if - ;; the pattern will always match. - ((null tests) t) - ((= (length tests) 1) (car tests)) - (t `(and . ,tests))))) - -(defun compile-select-tests (key pattern) - (cond ((constantp pattern) `((,(cond ((numberp pattern) 'eql) - ((symbolp pattern) 'eq) - (t 'equal)) - ,key ,pattern))) - ((symbolp pattern) '(t)) - ((select-double-match? pattern) - (append - (compile-select-tests key (first pattern)) - (compile-select-tests key (third pattern)))) - ((select-predicate? pattern) - (append - `((,(second (first pattern)) ,key)) - (compile-select-tests key (second pattern)))) - ((consp pattern) - (append - `((consp ,key)) - (compile-select-tests (cs-car key) (car - pattern)) - (compile-select-tests (cs-cdr key) (cdr - pattern)))) - (t (error "Illegal select pattern: ~S" pattern)))) - - -(defun compile-select-bindings (key pattern action) - (cond ((constantp pattern) '()) - ((symbolp pattern) - (if (select-in-tree pattern action) - `((,pattern ,key)) - '())) - ((select-double-match? pattern) - (append - (compile-select-bindings key (first pattern) action) - (compile-select-bindings key (third pattern) action))) - ((select-predicate? pattern) - (compile-select-bindings key (second pattern) action)) - ((consp pattern) - (append - (compile-select-bindings (cs-car key) (car pattern) - action) - (compile-select-bindings (cs-cdr key) (cdr pattern) - action))))) - -(defun select-in-tree (atom tree) - (or (eq atom tree) - (if (consp tree) - (or (select-in-tree atom (car tree)) - (select-in-tree atom (cdr tree)))))) - -(defun select-double-match? (pattern) - ;; ( = ) - (and (consp pattern) (consp (cdr pattern)) (consp (cddr pattern)) - (null (cdddr pattern)) - (eq (second pattern) '=))) - -(defun select-predicate? (pattern) - ;; ((function ) ) - (and (consp pattern) - (consp (cdr pattern)) - (null (cddr pattern)) - (consp (first pattern)) - (consp (cdr (first pattern))) - (null (cddr (first pattern))) - (eq (caar pattern) 'function))) - -(defun cs-car (exp) - (cs-car/cdr 'car exp - '((car . caar) (cdr . cadr) (caar . caaar) (cadr . caadr) - (cdar . cadar) (cddr . caddr) - (caaar . caaaar) (caadr . caaadr) (cadar . caadar) - (caddr . caaddr) (cdaar . cadaar) (cdadr . cadadr) - (cddar . caddar) (cdddr . cadddr)))) - -(defun cs-cdr (exp) - (cs-car/cdr 'cdr exp - '((car . cdar) (cdr . cddr) (caar . cdaar) (cadr . cdadr) - (cdar . cddar) (cddr . cdddr) - (caaar . cdaaar) (caadr . cdaadr) (cadar . cdadar) - (caddr . cdaddr) (cdaar . cddaar) (cdadr . cddadr) - (cddar . cdddar) (cdddr . cddddr)))) - -(defun cs-car/cdr (op exp table) - (if (and (consp exp) (= (length exp) 2)) - (let ((replacement (assoc (car exp) table))) - (if replacement - `(,(cdr replacement) ,(second exp)) - `(,op ,exp))) - `(,op ,exp))) - -;; (setf c1 '(select-match x (a 1) (b 2 3 4))) -;; (setf c2 '(select-match (car y) -;; (1 (print 100) 101) (2 200) ("hello" 5) (:x 20) (else (1+ -;; else)))) -;; (setf c3 '(select-match (caddr y) -;; ((all = (x y)) (list x y all)) -;; ((a '= b) (list 'assign a b)) -;; ((#'oddp k) (1+ k))))) - - diff --git a/lib/micros/swank/rpc.lisp b/lib/micros/swank/rpc.lisp deleted file mode 100644 index 341a8747c..000000000 --- a/lib/micros/swank/rpc.lisp +++ /dev/null @@ -1,162 +0,0 @@ -;;; -*- indent-tabs-mode: nil; coding: latin-1-unix -*- -;;; -;;; swank-rpc.lisp -- Pass remote calls and responses between lisp systems. -;;; -;;; Created 2010, Terje Norderhaug -;;; -;;; This code has been placed in the Public Domain. All warranties -;;; are disclaimed. -;;; - -(in-package micros/rpc) - - -;;;;; Input - -(defparameter *validate-input* nil - "Set to true to require input that more strictly conforms to the protocol") - -(define-condition swank-reader-error (reader-error) - ((packet :type string :initarg :packet - :reader swank-reader-error.packet) - (cause :type reader-error :initarg :cause - :reader swank-reader-error.cause))) - -(defun read-message (stream package &key (validate-input *validate-input*)) - (let ((packet (read-packet stream))) - (handler-case (values (read-form packet package :validate-input validate-input)) - (reader-error (c) - (error 'swank-reader-error - :packet packet :cause c))))) - -(defun read-packet (stream) - (let* ((length (parse-header stream)) - (octets (read-chunk stream length))) - (handler-case (micros/backend:utf8-to-string octets) - (error (c) - (error 'swank-reader-error - :packet (asciify octets) - :cause c))))) - -(defun asciify (packet) - (with-output-to-string (*standard-output*) - (loop for code across (etypecase packet - (string (map 'vector #'char-code packet)) - (vector packet)) - do (cond ((<= code #x7f) (write-char (code-char code))) - (t (format t "\\x~x" code)))))) - -(defun parse-header (stream) - (parse-integer (map 'string #'code-char (read-chunk stream 6)) - :radix 16)) - -(defun read-chunk (stream length) - (let* ((buffer (make-array length :element-type '(unsigned-byte 8))) - (count (read-sequence buffer stream))) - (cond ((= count length) - buffer) - ((zerop count) - (error 'end-of-file :stream stream)) - (t - (error "Short read: length=~D count=~D" length count))))) - -(defun read-form (string package &key ((:validate-input *validate-input*) nil)) - (with-standard-io-syntax - (let ((*package* package)) - (if *validate-input* - (validating-read string) - (read-from-string string))))) - -(defun validating-read (string) - (with-input-from-string (*standard-input* string) - (simple-read))) - -(defun simple-read () - "Read a form that conforms to the protocol, otherwise signal an error." - (let ((c (read-char))) - (case c - (#\( (loop collect (simple-read) - while (ecase (read-char) - (#\) nil) - (#\space t)))) - (#\' `(quote ,(simple-read))) - (t - (cond - ((digit-char-p c) - (parse-integer - (map 'simple-string #'identity - (loop for ch = c then (read-char nil nil) - while (and ch (digit-char-p ch)) - collect ch - finally (unread-char ch))))) - ((or (member c '(#\: #\")) (alpha-char-p c)) - (unread-char c) - (read-preserving-whitespace)) - (t (error "Invalid character ~:c" c))))))) - - -;;;;; Output - -(defun write-message (message package stream) - (let* ((string (prin1-to-string-for-emacs message package)) - (octets (handler-case (micros/backend:string-to-utf8 string) - (error (c) (encoding-error c string)))) - (length (length octets))) - (write-header stream length) - (write-sequence octets stream) - (finish-output stream))) - -;; FIXME: for now just tell emacs that we and an encoding problem. -(defun encoding-error (condition string) - (micros/backend:string-to-utf8 - (prin1-to-string-for-emacs - `(:reader-error - ,(asciify string) - ,(format nil "Error during string-to-utf8: ~a" - (or (ignore-errors (asciify (princ-to-string condition))) - (asciify (princ-to-string (type-of condition)))))) - (find-package :cl)))) - -(defun write-header (stream length) - (declare (type (unsigned-byte 24) length)) - ;;(format *trace-output* "length: ~d (#x~x)~%" length length) - (loop for c across (format nil "~6,'0x" length) - do (write-byte (char-code c) stream))) - -(defun switch-to-double-floats (x) - (typecase x - (double-float x) - (float (coerce x 'double-float)) - (null x) - (list (loop for (x . cdr) on x - collect (switch-to-double-floats x) into result - until (atom cdr) - finally (return (append result (switch-to-double-floats cdr))))) - (t x))) - -(defun prin1-to-string-for-emacs (object package) - (with-standard-io-syntax - (let ((*print-case* :downcase) - (*print-readably* nil) - (*print-pretty* nil) - (*package* package) - ;; Emacs has only double floats. - (*read-default-float-format* 'double-float)) - (prin1-to-string (switch-to-double-floats object))))) - - -#| TEST/DEMO: - -(defparameter *transport* - (with-output-to-string (out) - (write-message '(:message (hello "world")) *package* out) - (write-message '(:return 5) *package* out) - (write-message '(:emacs-rex NIL) *package* out))) - -*transport* - -(with-input-from-string (in *transport*) - (loop while (peek-char T in NIL) - collect (read-message in *package*))) - -|# diff --git a/lib/micros/swank/sbcl.lisp b/lib/micros/swank/sbcl.lisp deleted file mode 100644 index bcb52dd43..000000000 --- a/lib/micros/swank/sbcl.lisp +++ /dev/null @@ -1,2046 +0,0 @@ -;;;;; -*- indent-tabs-mode: nil -*- -;;; -;;; swank-sbcl.lisp --- SLIME backend for SBCL. -;;; -;;; Created 2003, Daniel Barlow -;;; -;;; This code has been placed in the Public Domain. All warranties are -;;; disclaimed. - -;;; Requires the SB-INTROSPECT contrib. - -;;; Administrivia - -(defpackage micros/sbcl - (:use cl micros/backend micros/source-path-parser micros/source-file-cache)) - -(in-package micros/sbcl) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (require 'sb-bsd-sockets) - (require 'sb-introspect) - (require 'sb-posix) - (require 'sb-cltl2)) - -(declaim (optimize (debug 2) - (sb-c::insert-step-conditions 0) - (sb-c::insert-debug-catch 0))) - -(declaim (special micros:*communication-style* - micros:*swank-debugger-condition*)) - -;;; backwards compability tests - -(eval-when (:compile-toplevel :load-toplevel :execute) - ;; Generate a form suitable for testing for stepper support (0.9.17) - ;; with #+. - (defun sbcl-with-new-stepper-p () - (with-symbol 'enable-stepping 'sb-impl)) - ;; Ditto for weak hash-tables - (defun sbcl-with-weak-hash-tables () - (with-symbol 'hash-table-weakness 'sb-ext)) - ;; And for xref support (1.0.1) - (defun sbcl-with-xref-p () - (with-symbol 'who-calls 'sb-introspect)) - ;; ... for restart-frame support (1.0.2) - (defun sbcl-with-restart-frame () - (with-symbol 'frame-has-debug-tag-p 'sb-debug)) - ;; ... for :setf :inverse info (1.1.17) - (defun sbcl-with-setf-inverse-meta-info () - (boolean-to-feature-expression - ;; going through FIND-SYMBOL since META-INFO was renamed from - ;; TYPE-INFO in 1.2.10. - (let ((sym (find-symbol "META-INFO" "SB-C"))) - (and sym - (fboundp sym) - (funcall sym :setf :inverse ())))))) - -;;; micros/mop - -(import-swank-mop-symbols :sb-mop '(:slot-definition-documentation)) - -(defun micros/mop:slot-definition-documentation (slot) - (sb-pcl::documentation slot t)) - -;; stream support - -(defimplementation gray-package-name () - "SB-GRAY") - -;; Pretty printer calls this, apparently -(defmethod sb-gray:stream-line-length - ((s sb-gray:fundamental-character-input-stream)) - nil) - -;;; Connection info - -(defimplementation lisp-implementation-type-name () - "sbcl") - -;; Declare return type explicitly to shut up STYLE-WARNINGS about -;; %SAP-ALIEN in ENABLE-SIGIO-ON-FD below. -(declaim (ftype (function () (values (signed-byte 32) &optional)) getpid)) -(defimplementation getpid () - (sb-posix:getpid)) - -;;; UTF8 - -(defimplementation string-to-utf8 (string) - (sb-ext:string-to-octets string :external-format '(:utf8 :replacement - #+sb-unicode #\Replacement_Character - #-sb-unicode #\? ))) - -(defimplementation utf8-to-string (octets) - (sb-ext:octets-to-string octets :external-format '(:utf8 :replacement - #+sb-unicode #\Replacement_Character - #-sb-unicode #\? ))) - -;;; TCP Server - -(defimplementation preferred-communication-style () - (cond - ;; fixme: when SBCL/win32 gains better select() support, remove - ;; this. - ((member :sb-thread *features*) :spawn) - ((member :win32 *features*) nil) - (t :fd-handler))) - - -(defun resolve-hostname (host) - "Returns valid IPv4 or IPv6 address for the host." - ;; get all IPv4 and IPv6 addresses as a list - (let* ((host-ents (multiple-value-list (sb-bsd-sockets:get-host-by-name host))) - ;; remove protocols for which we don't have an address - (addresses (remove-if-not #'sb-bsd-sockets:host-ent-address host-ents))) - ;; Return the first one or nil, - ;; but actually, it shouln't return nil, because - ;; get-host-by-name will signal NAME-SERVICE-ERROR condition - ;; if there isn't any address for the host. - (first addresses))) - - -(defimplementation create-socket (host port &key backlog) - (let* ((host-ent (resolve-hostname host)) - (socket (make-instance (cond #+#.(micros/backend:with-symbol 'inet6-socket 'sb-bsd-sockets) - ((eql (sb-bsd-sockets:host-ent-address-type host-ent) 10) - 'sb-bsd-sockets:inet6-socket) - (t - 'sb-bsd-sockets:inet-socket)) - :type :stream - :protocol :tcp))) - (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) - (sb-bsd-sockets:socket-bind socket (sb-bsd-sockets:host-ent-address host-ent) port) - - (sb-bsd-sockets:socket-listen socket (or backlog 5)) - socket)) - -(defimplementation local-port (socket) - (nth-value 1 (sb-bsd-sockets:socket-name socket))) - -(defimplementation close-socket (socket) - (sb-sys:invalidate-descriptor (socket-fd socket)) - (sb-bsd-sockets:socket-close socket)) - -(defimplementation accept-connection (socket &key - external-format - buffering timeout) - (declare (ignore timeout)) - (make-socket-io-stream (accept socket) external-format - (ecase buffering - ((t :full) :full) - ((nil :none) :none) - ((:line) :line)))) - - -;; The SIGIO stuff should probably be removed as it's unlikey that -;; anybody uses it. -#-win32 -(progn - (defimplementation install-sigint-handler (function) - (sb-sys:enable-interrupt sb-unix:sigint - (lambda (&rest args) - (declare (ignore args)) - (sb-sys:invoke-interruption - (lambda () - (sb-sys:with-interrupts - (funcall function))))))) - - (defvar *sigio-handlers* '() - "List of (key . fn) pairs to be called on SIGIO.") - - (defun sigio-handler (signal code scp) - (declare (ignore signal code scp)) - (sb-sys:with-interrupts - (mapc (lambda (handler) - (funcall (the function (cdr handler)))) - *sigio-handlers*))) - - (defun set-sigio-handler () - (sb-sys:enable-interrupt sb-unix:sigio #'sigio-handler)) - - (defun enable-sigio-on-fd (fd) - (sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async) - (sb-posix::fcntl fd sb-posix::f-setown (getpid)) - (values)) - - (defimplementation add-sigio-handler (socket fn) - (set-sigio-handler) - (let ((fd (socket-fd socket))) - (enable-sigio-on-fd fd) - (push (cons fd fn) *sigio-handlers*))) - - (defimplementation remove-sigio-handlers (socket) - (let ((fd (socket-fd socket))) - (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car)) - (sb-sys:invalidate-descriptor fd)) - (close socket))) - - -(defimplementation add-fd-handler (socket fun) - (let ((fd (socket-fd socket)) - (handler nil)) - (labels ((add () - (setq handler (sb-sys:add-fd-handler fd :input #'run))) - (run (fd) - (sb-sys:remove-fd-handler handler) ; prevent recursion - (unwind-protect - (funcall fun) - (when (sb-unix:unix-fstat fd) ; still open? - (add))))) - (add)))) - -(defimplementation remove-fd-handlers (socket) - (sb-sys:invalidate-descriptor (socket-fd socket))) - -(defimplementation socket-fd (socket) - (etypecase socket - (fixnum socket) - (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket)) - (file-stream (sb-sys:fd-stream-fd socket)))) - -(defimplementation command-line-args () - sb-ext:*posix-argv*) - -(defimplementation dup (fd) - (sb-posix:dup fd)) - -(defvar *wait-for-input-called*) - -(defimplementation wait-for-input (streams &optional timeout) - (assert (member timeout '(nil t))) - (when (boundp '*wait-for-input-called*) - (setq *wait-for-input-called* t)) - (let ((*wait-for-input-called* nil)) - (loop - (let ((ready (remove-if-not #'input-ready-p streams))) - (when ready (return ready))) - (when (check-slime-interrupts) - (return :interrupt)) - (when *wait-for-input-called* - (return :interrupt)) - (when timeout - (return nil)) - (sleep 0.1)))) - -(defun fd-stream-input-buffer-empty-p (stream) - (let ((buffer (sb-impl::fd-stream-ibuf stream))) - (or (not buffer) - (= (sb-impl::buffer-head buffer) - (sb-impl::buffer-tail buffer))))) - -#-win32 -(defun input-ready-p (stream) - (or (not (fd-stream-input-buffer-empty-p stream)) - #+#.(micros/backend:with-symbol 'fd-stream-fd-type 'sb-impl) - (eq :regular (sb-impl::fd-stream-fd-type stream)) - (not (sb-impl::sysread-may-block-p stream)))) - -#+win32 -(progn - (defun input-ready-p (stream) - (or (not (fd-stream-input-buffer-empty-p stream)) - (handle-listen (sockint::fd->handle (sb-impl::fd-stream-fd stream))))) - - (sb-alien:define-alien-routine ("WSACreateEvent" wsa-create-event) - sb-win32:handle) - - (sb-alien:define-alien-routine ("WSACloseEvent" wsa-close-event) - sb-alien:int - (event sb-win32:handle)) - - (defconstant +fd-read+ #.(ash 1 0)) - (defconstant +fd-close+ #.(ash 1 5)) - - (sb-alien:define-alien-routine ("WSAEventSelect" wsa-event-select) - sb-alien:int - (fd sb-alien:int) - (handle sb-win32:handle) - (mask sb-alien:long)) - - (sb-alien:load-shared-object "kernel32.dll") - (sb-alien:define-alien-routine ("WaitForSingleObjectEx" - wait-for-single-object-ex) - sb-alien:int - (event sb-win32:handle) - (milliseconds sb-alien:long) - (alertable sb-alien:int)) - - ;; see SB-WIN32:HANDLE-LISTEN - (defun handle-listen (handle) - (sb-alien:with-alien ((avail sb-win32:dword) - (buf (array char #.sb-win32::input-record-size))) - (unless (zerop (sb-win32:peek-named-pipe handle nil 0 nil - (sb-alien:alien-sap - (sb-alien:addr avail)) - nil)) - (return-from handle-listen (plusp avail))) - - (unless (zerop (sb-win32:peek-console-input handle - (sb-alien:alien-sap buf) - sb-win32::input-record-size - (sb-alien:alien-sap - (sb-alien:addr avail)))) - (return-from handle-listen (plusp avail)))) - - (let ((event (wsa-create-event))) - (wsa-event-select handle event (logior +fd-read+ +fd-close+)) - (let ((val (wait-for-single-object-ex event 0 0))) - (wsa-close-event event) - (unless (= val -1) - (return-from handle-listen (zerop val))))) - - nil) - - ) - -(defvar *external-format-to-coding-system* - '((:iso-8859-1 - "latin-1" "latin-1-unix" "iso-latin-1-unix" - "iso-8859-1" "iso-8859-1-unix") - (:utf-8 "utf-8" "utf-8-unix") - (:euc-jp "euc-jp" "euc-jp-unix") - (:us-ascii "us-ascii" "us-ascii-unix"))) - -;; C.f. R.M.Kreuter in <20536.1219412774@progn.net> on sbcl-general, -;; 2008-08-22. -(defvar *physical-pathname-host* (pathname-host (user-homedir-pathname))) - -(defimplementation filename-to-pathname (filename) - (sb-ext:parse-native-namestring filename *physical-pathname-host*)) - -(defimplementation find-external-format (coding-system) - (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) - *external-format-to-coding-system*))) - -(defimplementation set-default-directory (directory) - (let ((directory (truename (merge-pathnames directory)))) - (sb-posix:chdir directory) - (setf *default-pathname-defaults* directory) - (default-directory))) - -(defun make-socket-io-stream (socket external-format buffering) - (let ((args `(:output t - :input t - :element-type ,(if external-format - 'character - '(unsigned-byte 8)) - :buffering ,buffering - ,@(cond ((and external-format (sb-int:featurep :sb-unicode)) - `(:external-format ,external-format)) - (t '())) - :serve-events ,(eq :fd-handler micros:*communication-style*) - ;; SBCL < 1.0.42.43 doesn't support :SERVE-EVENTS - ;; argument. - :allow-other-keys t))) - (apply #'sb-bsd-sockets:socket-make-stream socket args))) - -(defun accept (socket) - "Like socket-accept, but retry on EAGAIN." - (loop (handler-case - (return (sb-bsd-sockets:socket-accept socket)) - (sb-bsd-sockets:interrupted-error ())))) - - -;;;; Support for SBCL syntax - -;;; SBCL's source code is riddled with #! reader macros. Also symbols -;;; containing `!' have special meaning. We have to work long and -;;; hard to be able to read the source. To deal with #! reader -;;; macros, we use a special readtable. The special symbols are -;;; converted by a condition handler. - -(defun feature-in-list-p (feature list) - (etypecase feature - (symbol (member feature list :test #'eq)) - (cons (flet ((subfeature-in-list-p (subfeature) - (feature-in-list-p subfeature list))) - ;; Don't use ECASE since SBCL also has :host-feature, - ;; don't need to handle it or anything else appearing in - ;; the future or in erronous code. - (case (first feature) - (:or (some #'subfeature-in-list-p (rest feature))) - (:and (every #'subfeature-in-list-p (rest feature))) - (:not (destructuring-bind (e) (cdr feature) - (not (subfeature-in-list-p e))))))))) - -(defun shebang-reader (stream sub-character infix-parameter) - (declare (ignore sub-character)) - (when infix-parameter - (error "illegal read syntax: #~D!" infix-parameter)) - (let ((next-char (read-char stream))) - (unless (find next-char "+-") - (error "illegal read syntax: #!~C" next-char)) - ;; When test is not satisfied - ;; FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then - ;; would become "unless test is satisfied".. - (when (let* ((*package* (find-package "KEYWORD")) - (*read-suppress* nil) - (not-p (char= next-char #\-)) - (feature (read stream))) - (if (feature-in-list-p feature *features*) - not-p - (not not-p))) - ;; Read (and discard) a form from input. - (let ((*read-suppress* t)) - (read stream t nil t)))) - (values)) - -(defvar *shebang-readtable* - (let ((*readtable* (copy-readtable nil))) - (set-dispatch-macro-character #\# #\! - (lambda (s c n) (shebang-reader s c n)) - *readtable*) - *readtable*)) - -(defun shebang-readtable () - *shebang-readtable*) - -(defun sbcl-package-p (package) - (let ((name (package-name package))) - (eql (mismatch "SB-" name) 3))) - -(defun sbcl-source-file-p (filename) - (when filename - (loop for (nil pattern) in (logical-pathname-translations "SYS") - thereis (pathname-match-p filename pattern)))) - -(defun guess-readtable-for-filename (filename) - (if (sbcl-source-file-p filename) - (shebang-readtable) - *readtable*)) - -(defvar *debootstrap-packages* t) - -(defun call-with-debootstrapping (fun) - (handler-bind ((sb-int:bootstrap-package-not-found - #'sb-int:debootstrap-package)) - (funcall fun))) - -(defmacro with-debootstrapping (&body body) - `(call-with-debootstrapping (lambda () ,@body))) - -(defimplementation call-with-syntax-hooks (fn) - (cond ((and *debootstrap-packages* - (sbcl-package-p *package*)) - (with-debootstrapping (funcall fn))) - (t - (funcall fn)))) - -(defimplementation default-readtable-alist () - (let ((readtable (shebang-readtable))) - (loop for p in (remove-if-not #'sbcl-package-p (list-all-packages)) - collect (cons (package-name p) readtable)))) - -;;; Packages - -#+#.(micros/backend:with-symbol 'package-local-nicknames 'sb-ext) -(defimplementation package-local-nicknames (package) - (sb-ext:package-local-nicknames package)) - -;;; Utilities - -#+#.(micros/backend:with-symbol 'function-lambda-list 'sb-introspect) -(defimplementation arglist (fname) - (sb-introspect:function-lambda-list fname)) - -#-#.(micros/backend:with-symbol 'function-lambda-list 'sb-introspect) -(defimplementation arglist (fname) - (sb-introspect:function-arglist fname)) - -(defimplementation function-name (f) - (check-type f function) - (sb-impl::%fun-name f)) - -(defmethod declaration-arglist ((decl-identifier (eql 'optimize))) - (flet ((ensure-list (thing) (if (listp thing) thing (list thing)))) - (let* ((flags (sb-cltl2:declaration-information decl-identifier))) - (if flags - ;; Symbols aren't printed with package qualifiers, but the - ;; FLAGS would have to be fully qualified when used inside a - ;; declaration. So we strip those as long as there's no - ;; better way. (FIXME) - `(&any ,@(remove-if-not - #'(lambda (qualifier) - (find-symbol (symbol-name (first qualifier)) :cl)) - flags :key #'ensure-list)) - (call-next-method))))) - -#+#.(micros/backend:with-symbol 'deftype-lambda-list 'sb-introspect) -(defmethod type-specifier-arglist :around (typespec-operator) - (multiple-value-bind (arglist foundp) - (sb-introspect:deftype-lambda-list typespec-operator) - (if foundp arglist (call-next-method)))) - -(defimplementation type-specifier-p (symbol) - (or (sb-ext:valid-type-specifier-p symbol) - (not (eq (type-specifier-arglist symbol) :not-available)))) - -(defvar *buffer-name* nil) -(defvar *buffer-tmpfile* nil) -(defvar *buffer-offset*) -(defvar *buffer-substring* nil) - -(defvar *previous-compiler-condition* nil - "Used to detect duplicates.") - -(defun handle-notification-condition (condition) - "Handle a condition caused by a compiler warning. -This traps all compiler conditions at a lower-level than using -C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to -craft our own error messages, which can omit a lot of redundant -information." - (unless (or (eq condition *previous-compiler-condition*)) - ;; First resignal warnings, so that outer handlers -- which may choose to - ;; muffle this -- get a chance to run. - (when (typep condition 'warning) - (signal condition)) - (setq *previous-compiler-condition* condition) - (signal-compiler-condition (real-condition condition) - (sb-c::find-error-context nil)))) - -(defun signal-compiler-condition (condition context) - (signal 'compiler-condition - :original-condition condition - :severity (etypecase condition - (sb-ext:compiler-note :note) - (sb-c:compiler-error :error) - (reader-error :read-error) - (error :error) - #+#.(micros/backend:with-symbol early-deprecation-warning sb-ext) - (sb-ext::early-deprecation-warning :early-deprecation-warning) - #+#.(micros/backend:with-symbol late-deprecation-warning sb-ext) - (sb-ext::late-deprecation-warning :late-deprecation-warning) - #+#.(micros/backend:with-symbol final-deprecation-warning sb-ext) - (sb-ext::final-deprecation-warning :final-deprecation-warning) - #+#.(micros/backend:with-symbol redefinition-warning - sb-kernel) - (sb-kernel:redefinition-warning - :redefinition) - (style-warning :style-warning) - (warning :warning)) - :references (condition-references condition) - :message (brief-compiler-message-for-emacs condition) - :source-context (compiler-error-context context) - :location (compiler-note-location condition context))) - -(defun real-condition (condition) - "Return the encapsulated condition or CONDITION itself." - (typecase condition - (sb-int:encapsulated-condition (sb-int:encapsulated-condition condition)) - (t condition))) - -(defun condition-references (condition) - (if (typep condition 'sb-int:reference-condition) - (externalize-reference - (sb-int:reference-condition-references condition)))) - -(defun compiler-note-location (condition context) - (flet ((bailout () - (return-from compiler-note-location - (make-error-location "No error location available")))) - (cond (context - (locate-compiler-note - (sb-c::compiler-error-context-file-name context) - (compiler-source-path context) - (sb-c::compiler-error-context-original-source context))) - ((typep condition 'reader-error) - (let* ((stream (stream-error-stream condition)) - ;; If STREAM is, for example, a STRING-INPUT-STREAM, - ;; an error will be signaled since PATHNAME only - ;; accepts a "stream associated with a file" which - ;; is a complicated predicate and hard to test - ;; portably. - (file (ignore-errors (pathname stream)))) - (unless (and file (open-stream-p stream)) - (bailout)) - (if (compiling-from-buffer-p file) - ;; The stream position for e.g. "comma not inside - ;; backquote" is at the character following the - ;; comma, :offset is 0-based, hence the 1-. - (make-location (list :buffer *buffer-name*) - (list :offset *buffer-offset* - (1- (file-position stream)))) - (progn - (assert (compiling-from-file-p file)) - ;; No 1- because :position is 1-based. - (make-location (list :file (namestring file)) - (list :position (file-position stream))))))) - (t (bailout))))) - -(defun compiling-from-buffer-p (filename) - (and *buffer-name* - ;; The following is to trigger COMPILING-FROM-GENERATED-CODE-P - ;; in LOCATE-COMPILER-NOTE, and allows handling nested - ;; compilation from eg. hitting C-C on (eval-when ... (require ..))). - ;; - ;; PROBE-FILE to handle tempfile directory being a symlink. - (pathnamep filename) - (let ((true1 (probe-file filename)) - (true2 (probe-file *buffer-tmpfile*))) - (and true1 (equal true1 true2))))) - -(defun compiling-from-file-p (filename) - (and (pathnamep filename) - (or (null *buffer-name*) - (null *buffer-tmpfile*) - (let ((true1 (probe-file filename)) - (true2 (probe-file *buffer-tmpfile*))) - (not (and true1 (equal true1 true2))))))) - -(defun compiling-from-generated-code-p (filename source) - (and (eq filename :lisp) (stringp source))) - -(defun locate-compiler-note (file source-path source) - (cond ((compiling-from-buffer-p file) - (make-location (list :buffer *buffer-name*) - (list :offset *buffer-offset* - (source-path-string-position - source-path *buffer-substring*)))) - ((compiling-from-file-p file) - (let ((position (source-path-file-position source-path file))) - (make-location (list :file (namestring file)) - (list :position (and position - (1+ position)))))) - ((compiling-from-generated-code-p file source) - (make-location (list :source-form source) - (list :position 1))) - (t - (error "unhandled case in compiler note ~S ~S ~S" - file source-path source)))) - -(defun brief-compiler-message-for-emacs (condition) - "Briefly describe a compiler error for Emacs. -When Emacs presents the message it already has the source popped up -and the source form highlighted. This makes much of the information in -the error-context redundant." - (let ((sb-int:*print-condition-references* nil)) - (princ-to-string condition))) - -(defun compiler-error-context (error-context) - "Describe a compiler error for Emacs including context information." - (declare (type (or sb-c::compiler-error-context null) error-context)) - (multiple-value-bind (enclosing source) - (if error-context - (values (sb-c::compiler-error-context-enclosing-source error-context) - (sb-c::compiler-error-context-source error-context))) - (and (or enclosing source) - (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]" - enclosing source)))) - -(defun compiler-source-path (context) - "Return the source-path for the current compiler error. -Returns NIL if this cannot be determined by examining internal -compiler state." - (cond ((sb-c::node-p context) - (reverse - (sb-c::source-path-original-source - (sb-c::node-source-path context)))) - ((sb-c::compiler-error-context-p context) - (reverse - (sb-c::compiler-error-context-original-source-path context))))) - -(defimplementation call-with-compilation-hooks (function) - (declare (type function function)) - (handler-bind - ;; N.B. Even though these handlers are called HANDLE-FOO they - ;; actually decline, i.e. the signalling of the original - ;; condition continues upward. - ((sb-c:fatal-compiler-error #'handle-notification-condition) - (sb-c:compiler-error #'handle-notification-condition) - (sb-ext:compiler-note #'handle-notification-condition) - (error #'handle-notification-condition) - (warning #'handle-notification-condition)) - (funcall function))) - -;;; HACK: SBCL 1.2.12 shipped with a bug where -;;; SB-EXT:RESTRICT-COMPILER-POLICY would signal an error when there -;;; were no policy restrictions in place. This workaround ensures the -;;; existence of at least one dummy restriction. -(handler-case (sb-ext:restrict-compiler-policy) - (error () (sb-ext:restrict-compiler-policy 'debug))) - -(defun compiler-policy (qualities) - "Return compiler policy qualities present in the QUALITIES alist. -QUALITIES is an alist with (quality . value)" - #+#.(micros/backend:with-symbol 'restrict-compiler-policy 'sb-ext) - (loop with policy = (sb-ext:restrict-compiler-policy) - for (quality) in qualities - collect (cons quality - (or (cdr (assoc quality policy)) - 0)))) - -(defun (setf compiler-policy) (policy) - (declare (ignorable policy)) - #+#.(micros/backend:with-symbol 'restrict-compiler-policy 'sb-ext) - (loop for (qual . value) in policy - do (sb-ext:restrict-compiler-policy qual value))) - -(defmacro with-compiler-policy (policy &body body) - (let ((current-policy (gensym))) - `(let ((,current-policy (compiler-policy ,policy))) - (setf (compiler-policy) ,policy) - (unwind-protect (progn ,@body) - (setf (compiler-policy) ,current-policy))))) - -(defimplementation swank-compile-file (input-file output-file - load-p external-format - &key policy) - (multiple-value-bind (output-file warnings-p failure-p) - (with-compiler-policy policy - (with-compilation-hooks () - (compile-file input-file :output-file output-file - :external-format external-format))) - (values output-file warnings-p - (or failure-p - (when load-p - ;; Cache the latest source file for definition-finding. - (source-cache-get input-file - (file-write-date input-file)) - (not (load output-file))))))) - -;;;; compile-string - -;;; We copy the string to a temporary file in order to get adequate -;;; semantics for :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL EVAL-WHEN forms -;;; which the previous approach using -;;; (compile nil `(lambda () ,(read-from-string string))) -;;; did not provide. - -(locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) - -(sb-alien:define-alien-routine (#-win32 "tempnam" #+win32 "_tempnam" tempnam) - sb-alien:c-string - (dir sb-alien:c-string) - (prefix sb-alien:c-string))) - -(defun temp-file-name () - "Return a temporary file name to compile strings into." - (tempnam nil "slime")) - -(defvar *trap-load-time-warnings* t) - -(defimplementation swank-compile-string (string &key buffer position filename - line column policy) - (declare (ignore line column)) - (let ((*buffer-name* buffer) - (*buffer-offset* position) - (*buffer-substring* string) - (*buffer-tmpfile* (temp-file-name))) - (labels ((load-it (filename) - (cond (*trap-load-time-warnings* - (with-compilation-hooks () (load filename))) - (t (load filename)))) - (cf () - (with-compiler-policy policy - (with-compilation-unit - (:source-plist (list :emacs-buffer buffer - :emacs-filename filename - :emacs-package (package-name *package*) - :emacs-position position - :emacs-string string) - :source-namestring filename - :allow-other-keys t) - (compile-file *buffer-tmpfile* :external-format :utf-8))))) - (with-open-file (s *buffer-tmpfile* :direction :output :if-exists :error - :external-format :utf-8) - (write-string string s)) - (unwind-protect - (multiple-value-bind (output-file warningsp failurep) - (with-compilation-hooks () (cf)) - (declare (ignore warningsp)) - (when output-file - (load-it output-file)) - (not failurep)) - (ignore-errors - (delete-file *buffer-tmpfile*) - (delete-file (compile-file-pathname *buffer-tmpfile*))))))) - -;;;; Definitions - -(defparameter *definition-types* - '(:variable defvar - :constant defconstant - :type deftype - :symbol-macro define-symbol-macro - :macro defmacro - :compiler-macro define-compiler-macro - :function defun - :generic-function defgeneric - :method defmethod - :setf-expander define-setf-expander - :structure defstruct - :condition define-condition - :class defclass - :method-combination define-method-combination - :package defpackage - :transform :deftransform - :optimizer :defoptimizer - :vop :define-vop - :source-transform :define-source-transform - :ir1-convert :def-ir1-translator - :declaration declaim - :alien-type :define-alien-type) - "Map SB-INTROSPECT definition type names to Slime-friendly forms") - -(defun definition-specifier (type) - "Return a pretty specifier for NAME representing a definition of type TYPE." - (getf *definition-types* type)) - -(defun make-dspec (type name source-location) - (list* (definition-specifier type) - name - (sb-introspect::definition-source-description source-location))) - -(defimplementation find-definitions (name) - (loop for type in *definition-types* by #'cddr - for defsrcs = (sb-introspect:find-definition-sources-by-name name type) - for filtered-defsrcs = (if (eq type :generic-function) - (remove :invalid defsrcs - :key #'categorize-definition-source) - defsrcs) - append (loop for defsrc in filtered-defsrcs collect - (list (make-dspec type name defsrc) - (converting-errors-to-error-location - (definition-source-for-emacs defsrc - type name)))))) - -(defimplementation find-source-location (obj) - (flet ((general-type-of (obj) - (typecase obj - (method :method) - (generic-function :generic-function) - (function :function) - (structure-class :structure-class) - (class :class) - (method-combination :method-combination) - (package :package) - (condition :condition) - (structure-object :structure-object) - (standard-object :standard-object) - (t :thing))) - (to-string (obj) - (typecase obj - ;; Packages are possibly named entities. - (package (princ-to-string obj)) - ((or structure-object standard-object condition) - (with-output-to-string (s) - (print-unreadable-object (obj s :type t :identity t)))) - (t (princ-to-string obj))))) - (converting-errors-to-error-location - (let ((defsrc (sb-introspect:find-definition-source obj))) - (definition-source-for-emacs defsrc - (general-type-of obj) - (to-string obj)))))) - -(defmacro with-definition-source ((&rest names) obj &body body) - "Like with-slots but works only for structs." - (flet ((reader (slot) - ;; Use read-from-string instead of intern so that - ;; conc-name can be a string such as ext:struct- and not - ;; cause errors and not force interning ext::struct- - (read-from-string - (concatenate 'string "sb-introspect:definition-source-" - (string slot))))) - (let ((tmp (gensym "OO-"))) - ` (let ((,tmp ,obj)) - (symbol-macrolet - ,(loop for name in names collect - (typecase name - (symbol `(,name (,(reader name) ,tmp))) - (cons `(,(first name) (,(reader (second name)) ,tmp))) - (t (error "Malformed syntax in WITH-STRUCT: ~A" name)))) - ,@body))))) - -(defun categorize-definition-source (definition-source) - (with-definition-source (pathname form-path character-offset plist) - definition-source - (let ((file-p (and pathname (probe-file pathname) - (or form-path character-offset)))) - (cond ((and (getf plist :emacs-buffer) file-p) :buffer-and-file) - ((getf plist :emacs-buffer) :buffer) - (file-p :file) - (pathname :file-without-position) - (t :invalid))))) - -#+#.(micros/backend:with-symbol 'definition-source-form-number 'sb-introspect) -(defun form-number-position (definition-source stream) - (let* ((tlf-number (car (sb-introspect:definition-source-form-path definition-source))) - (form-number (sb-introspect:definition-source-form-number definition-source))) - (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream) - (let* ((path-table (sb-di::form-number-translations tlf 0)) - (path (cond ((<= (length path-table) form-number) - (warn "inconsistent form-number-translations") - (list 0)) - (t - (reverse (cdr (aref path-table form-number))))))) - (source-path-source-position path tlf pos-map))))) - -#+#.(micros/backend:with-symbol 'definition-source-form-number 'sb-introspect) -(defun file-form-number-position (definition-source) - (let* ((code-date (sb-introspect:definition-source-file-write-date definition-source)) - (filename (sb-introspect:definition-source-pathname definition-source)) - (*readtable* (guess-readtable-for-filename filename)) - (source-code (get-source-code filename code-date))) - (with-debootstrapping - (with-input-from-string (s source-code) - (form-number-position definition-source s))))) - -#+#.(micros/backend:with-symbol 'definition-source-form-number 'sb-introspect) -(defun string-form-number-position (definition-source string) - (with-input-from-string (s string) - (form-number-position definition-source s))) - -(defun definition-source-buffer-location (definition-source) - (with-definition-source (form-path character-offset plist) definition-source - (destructuring-bind (&key emacs-buffer emacs-position emacs-directory - emacs-string &allow-other-keys) - plist - (let ((*readtable* (guess-readtable-for-filename emacs-directory)) - start - end) - (with-debootstrapping - (or - (and form-path - (or - #+#.(micros/backend:with-symbol 'definition-source-form-number 'sb-introspect) - (setf (values start end) - (and (sb-introspect:definition-source-form-number definition-source) - (string-form-number-position definition-source emacs-string))) - (setf (values start end) - (source-path-string-position form-path emacs-string)))) - (setf start character-offset - end most-positive-fixnum))) - (make-location - `(:buffer ,emacs-buffer) - `(:offset ,emacs-position ,start) - `(:snippet - ,(subseq emacs-string - start - (min end (+ start *source-snippet-size*))))))))) - -(defun definition-source-file-location (definition-source) - (with-definition-source (pathname form-path character-offset plist - file-write-date) definition-source - (let* ((namestring (namestring (translate-logical-pathname pathname))) - (pos (or (and form-path - (or - #+#.(micros/backend:with-symbol 'definition-source-form-number 'sb-introspect) - (and (sb-introspect:definition-source-form-number definition-source) - (ignore-errors (file-form-number-position definition-source))) - (ignore-errors - (source-file-position namestring file-write-date - form-path)))) - character-offset)) - (snippet (source-hint-snippet namestring file-write-date pos))) - (make-location `(:file ,namestring) - ;; /file positions/ in Common Lisp start from - ;; 0, buffer positions in Emacs start from 1. - `(:position ,(1+ pos)) - `(:snippet ,snippet))))) - -(defun definition-source-buffer-and-file-location (definition-source) - (let ((buffer (definition-source-buffer-location definition-source))) - (make-location (list :buffer-and-file - (cadr (location-buffer buffer)) - (namestring (sb-introspect:definition-source-pathname - definition-source))) - (location-position buffer) - (location-hints buffer)))) - -(defun definition-source-for-emacs (definition-source type name) - (with-definition-source (pathname form-path character-offset plist - file-write-date) - definition-source - (ecase (categorize-definition-source definition-source) - (:buffer-and-file - (definition-source-buffer-and-file-location definition-source)) - (:buffer - (definition-source-buffer-location definition-source)) - (:file - (definition-source-file-location definition-source)) - (:file-without-position - (make-location `(:file ,(namestring - (translate-logical-pathname pathname))) - '(:position 1) - (when (eql type :function) - `(:snippet ,(format nil "(defun ~a " - (symbol-name name)))))) - (:invalid - (error "DEFINITION-SOURCE of ~(~A~) ~A did not contain ~ - meaningful information." - type name))))) - -(defun source-file-position (filename write-date form-path) - (let ((source (get-source-code filename write-date)) - (*readtable* (guess-readtable-for-filename filename))) - (with-debootstrapping - (source-path-string-position form-path source)))) - -(defun source-hint-snippet (filename write-date position) - (read-snippet-from-string (get-source-code filename write-date) position)) - -(defun function-source-location (function &optional name) - (declare (type function function)) - (definition-source-for-emacs (sb-introspect:find-definition-source function) - :function - (or name (function-name function)))) - -(defun setf-expander (symbol) - (or - #+#.(micros/sbcl::sbcl-with-setf-inverse-meta-info) - (sb-int:info :setf :inverse symbol) - (sb-int:info :setf :expander symbol))) - -(defimplementation describe-symbol-for-emacs (symbol) - "Return a plist describing SYMBOL. -Return NIL if the symbol is unbound." - (let ((result '())) - (flet ((doc (kind) - (or (documentation symbol kind) :not-documented)) - (maybe-push (property value) - (when value - (setf result (list* property value result))))) - (maybe-push - :variable (multiple-value-bind (kind recorded-p) - (sb-int:info :variable :kind symbol) - (declare (ignore kind)) - (if (or (boundp symbol) recorded-p) - (doc 'variable)))) - (when (fboundp symbol) - (maybe-push - (cond ((macro-function symbol) :macro) - ((special-operator-p symbol) :special-operator) - ((typep (fdefinition symbol) 'generic-function) - :generic-function) - (t :function)) - (doc 'function))) - (maybe-push - :setf (and (setf-expander symbol) - (doc 'setf))) - (maybe-push - :type (if (sb-int:info :type :kind symbol) - (doc 'type))) - result))) - -(defimplementation describe-definition (symbol type) - (case type - (:variable - (describe symbol)) - (:function - (describe (symbol-function symbol))) - (:setf - (describe (setf-expander symbol))) - (:class - (describe (find-class symbol))) - (:type - (describe (sb-kernel:values-specifier-type symbol))))) - -#+#.(micros/sbcl::sbcl-with-xref-p) -(progn - (defmacro defxref (name &optional fn-name) - `(defimplementation ,name (what) - (sanitize-xrefs - (mapcar #'source-location-for-xref-data - (,(find-symbol (symbol-name (if fn-name - fn-name - name)) - "SB-INTROSPECT") - what))))) - (defxref who-calls) - (defxref who-binds) - (defxref who-sets) - (defxref who-references) - (defxref who-macroexpands) - #+#.(micros/backend:with-symbol 'who-specializes-directly 'sb-introspect) - (defxref who-specializes who-specializes-directly)) - -(defun source-location-for-xref-data (xref-data) - (destructuring-bind (name . defsrc) xref-data - (list name (converting-errors-to-error-location - (definition-source-for-emacs defsrc 'function name))))) - -(defimplementation list-callers (symbol) - (let ((fn (fdefinition symbol))) - (sanitize-xrefs - (mapcar #'function-dspec (sb-introspect:find-function-callers fn))))) - -(defimplementation list-callees (symbol) - (let ((fn (fdefinition symbol))) - (sanitize-xrefs - (mapcar #'function-dspec (sb-introspect:find-function-callees fn))))) - -(defun sanitize-xrefs (xrefs) - (remove-duplicates - (remove-if (lambda (f) - (member f (ignored-xref-function-names))) - (loop for entry in xrefs - for name = (car entry) - collect (if (and (consp name) - (member (car name) - '(sb-pcl::fast-method - sb-pcl::slow-method - sb-pcl::method))) - (cons (cons 'defmethod (cdr name)) - (cdr entry)) - entry)) - :key #'car) - :test (lambda (a b) - (and (eq (first a) (first b)) - (equal (second a) (second b)))))) - -(defun ignored-xref-function-names () - #-#.(micros/sbcl::sbcl-with-new-stepper-p) - '(nil sb-c::step-form sb-c::step-values) - #+#.(micros/sbcl::sbcl-with-new-stepper-p) - '(nil)) - -(defun function-dspec (fn) - "Describe where the function FN was defined. -Return a list of the form (NAME LOCATION)." - (let ((name (function-name fn))) - (list name (converting-errors-to-error-location - (function-source-location fn name))))) - -;;; macroexpansion - -(defimplementation macroexpand-all (form &optional env) - (sb-cltl2:macroexpand-all form env)) - -(defimplementation collect-macro-forms (form &optional environment) - (let ((macro-forms '()) - (compiler-macro-forms '()) - (function-quoted-forms '())) - (sb-walker:walk-form - form environment - (lambda (form context environment) - (declare (ignore context)) - (when (and (consp form) - (symbolp (car form))) - (cond ((eq (car form) 'function) - (push (cadr form) function-quoted-forms)) - ((member form function-quoted-forms) - nil) - ((macro-function (car form) environment) - (push form macro-forms)) - ((not (eq form (compiler-macroexpand-1 form environment))) - (push form compiler-macro-forms)))) - form)) - (values macro-forms compiler-macro-forms))) - - -;;; Debugging - -;;; Notice that SB-EXT:*INVOKE-DEBUGGER-HOOK* is slightly stronger -;;; than just a hook into BREAK. In particular, it'll make -;;; (LET ((*DEBUGGER-HOOK* NIL)) ..error..) drop into SLDB rather -;;; than the native debugger. That should probably be considered a -;;; feature. - -(defun make-invoke-debugger-hook (hook) - (when hook - #'(sb-int:named-lambda swank-invoke-debugger-hook - (condition old-hook) - (if *debugger-hook* - nil ; decline, *DEBUGGER-HOOK* will be tried next. - (funcall hook condition old-hook))))) - -(defun set-break-hook (hook) - (setq sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))) - -(defun call-with-break-hook (hook continuation) - (let ((sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))) - (funcall continuation))) - -(defimplementation install-debugger-globally (function) - (setq *debugger-hook* function) - (set-break-hook function)) - -(defimplementation condition-extras (condition) - (cond #+#.(micros/sbcl::sbcl-with-new-stepper-p) - ((typep condition 'sb-impl::step-form-condition) - `((:show-frame-source 0))) - ((typep condition 'sb-int:reference-condition) - (let ((refs (sb-int:reference-condition-references condition))) - (if refs - `((:references ,(externalize-reference refs)))))))) - -(defun externalize-reference (ref) - (etypecase ref - (null nil) - (cons (cons (externalize-reference (car ref)) - (externalize-reference (cdr ref)))) - ((or string number) ref) - (symbol - (cond ((eq (symbol-package ref) (symbol-package :test)) - ref) - (t (symbol-name ref)))))) - -(defvar *sldb-stack-top*) - -(defimplementation call-with-debugging-environment (debugger-loop-fn) - (declare (type function debugger-loop-fn)) - (let ((*sldb-stack-top* - (if (and (not *debug-swank-backend*) - sb-debug:*stack-top-hint*) - #+#.(micros/backend:with-symbol 'resolve-stack-top-hint 'sb-debug) - (sb-debug::resolve-stack-top-hint) - #-#.(micros/backend:with-symbol 'resolve-stack-top-hint 'sb-debug) - sb-debug:*stack-top-hint* - (sb-di:top-frame))) - (sb-debug:*stack-top-hint* nil)) - (handler-bind ((sb-di:debug-condition - (lambda (condition) - (signal 'sldb-condition - :original-condition condition)))) - (funcall debugger-loop-fn)))) - -#+#.(micros/sbcl::sbcl-with-new-stepper-p) -(progn - (defimplementation activate-stepping (frame) - (declare (ignore frame)) - (sb-impl::enable-stepping)) - (defimplementation sldb-stepper-condition-p (condition) - (typep condition 'sb-ext:step-form-condition)) - (defimplementation sldb-step-into () - (invoke-restart 'sb-ext:step-into)) - (defimplementation sldb-step-next () - (invoke-restart 'sb-ext:step-next)) - (defimplementation sldb-step-out () - (invoke-restart 'sb-ext:step-out))) - -(defimplementation call-with-debugger-hook (hook fun) - (let ((*debugger-hook* hook) - #+#.(micros/sbcl::sbcl-with-new-stepper-p) - (sb-ext:*stepper-hook* - (lambda (condition) - (typecase condition - (sb-ext:step-form-condition - (let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame))) - (sb-impl::invoke-debugger condition))))))) - (handler-bind (#+#.(micros/sbcl::sbcl-with-new-stepper-p) - (sb-ext:step-condition #'sb-impl::invoke-stepper)) - (call-with-break-hook hook fun)))) - -(defun nth-frame (index) - (do ((frame *sldb-stack-top* (sb-di:frame-down frame)) - (i index (1- i))) - ((zerop i) frame))) - -(defimplementation compute-backtrace (start end) - "Return a list of frames starting with frame number START and -continuing to frame number END or, if END is nil, the last frame on the -stack." - (let ((end (or end most-positive-fixnum))) - (loop for f = (nth-frame start) then (sb-di:frame-down f) - for i from start below end - while f collect f))) - -(defimplementation print-frame (frame stream) - (sb-debug::print-frame-call frame stream - :allow-other-keys t - :emergency-best-effort t)) - -(defimplementation frame-restartable-p (frame) - #+#.(micros/sbcl::sbcl-with-restart-frame) - (not (null (sb-debug:frame-has-debug-tag-p frame)))) - -(defimplementation frame-call (frame-number) - (multiple-value-bind (name args) - (sb-debug::frame-call (nth-frame frame-number)) - (with-output-to-string (stream) - (locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) - (pprint-logical-block (stream nil :prefix "(" :suffix ")") - (locally (declare (sb-ext:unmuffle-conditions sb-ext:compiler-note)) - (let ((*print-length* nil) - (*print-level* nil)) - (prin1 (sb-debug::ensure-printable-object name) stream)) - (let ((args (sb-debug::ensure-printable-object args))) - (if (listp args) - (format stream "~{ ~_~S~}" args) - (format stream " ~S" args))))))))) - -;;;; Code-location -> source-location translation - -;;; If debug-block info is avaibale, we determine the file position of -;;; the source-path for a code-location. If the code was compiled -;;; with C-c C-c, we have to search the position in the source string. -;;; If there's no debug-block info, we return the (less precise) -;;; source-location of the corresponding function. - -(defun code-location-source-location (code-location) - (let* ((dsource (sb-di:code-location-debug-source code-location)) - (plist (sb-c::debug-source-plist dsource)) - (package (getf plist :emacs-package)) - (*package* (or (and package - (find-package package)) - *package*))) - (if (getf plist :emacs-buffer) - (emacs-buffer-source-location code-location plist) - #+#.(micros/backend:with-symbol 'debug-source-from 'sb-di) - (ecase (sb-di:debug-source-from dsource) - (:file (file-source-location code-location)) - (:lisp (lisp-source-location code-location))) - #-#.(micros/backend:with-symbol 'debug-source-from 'sb-di) - (if (sb-di:debug-source-namestring dsource) - (file-source-location code-location) - (lisp-source-location code-location))))) - -;;; FIXME: The naming policy of source-location functions is a bit -;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the -;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co -;;; which returns the source location for a _code-location_. -;;; -;;; Maybe these should be named code-location-file-source-location, -;;; etc, turned into generic functions, or something. In the very -;;; least the names should indicate the main entry point vs. helper -;;; status. - -(defun file-source-location (code-location) - (if (code-location-has-debug-block-info-p code-location) - (source-file-source-location code-location) - (fallback-source-location code-location))) - -(defun fallback-source-location (code-location) - (let ((fun (code-location-debug-fun-fun code-location))) - (cond (fun (function-source-location fun)) - (t (error "Cannot find source location for: ~A " code-location))))) - -(defun lisp-source-location (code-location) - (let ((source (prin1-to-string - (sb-debug::code-location-source-form code-location 100))) - (condition micros:*swank-debugger-condition*)) - (if (and (typep condition 'sb-impl::step-form-condition) - (search "SB-IMPL::WITH-STEPPING-ENABLED" source - :test #'char-equal) - (search "SB-IMPL::STEP-FINISHED" source :test #'char-equal)) - ;; The initial form is utterly uninteresting -- and almost - ;; certainly right there in the REPL. - (make-error-location "Stepping...") - (make-location `(:source-form ,source) '(:position 1))))) - -(defun emacs-buffer-source-location (code-location plist) - (if (code-location-has-debug-block-info-p code-location) - (destructuring-bind (&key emacs-buffer emacs-position emacs-string - &allow-other-keys) - plist - (let* ((pos (string-source-position code-location emacs-string)) - (snipped (read-snippet-from-string emacs-string pos))) - (make-location `(:buffer ,emacs-buffer) - `(:offset ,emacs-position ,pos) - `(:snippet ,snipped)))) - (fallback-source-location code-location))) - -(defun source-file-source-location (code-location) - (let* ((code-date (code-location-debug-source-created code-location)) - (filename (code-location-debug-source-name code-location)) - (*readtable* (guess-readtable-for-filename filename)) - (source-code (get-source-code filename code-date))) - (with-debootstrapping - (with-input-from-string (s source-code) - (let* ((pos (stream-source-position code-location s)) - (snippet (read-snippet s pos))) - (make-location `(:file ,filename) - `(:position ,pos) - `(:snippet ,snippet))))))) - -(defun code-location-debug-source-name (code-location) - (namestring (truename (#.(micros/backend:choose-symbol - 'sb-c 'debug-source-name - 'sb-c 'debug-source-namestring) - (sb-di::code-location-debug-source code-location))))) - -(defun code-location-debug-source-created (code-location) - (sb-c::debug-source-created - (sb-di::code-location-debug-source code-location))) - -(defun code-location-debug-fun-fun (code-location) - (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location))) - -(defun code-location-has-debug-block-info-p (code-location) - (handler-case - (progn (sb-di:code-location-debug-block code-location) - t) - (sb-di:no-debug-blocks () nil))) - -(defun stream-source-position (code-location stream) - (let* ((cloc (sb-debug::maybe-block-start-location code-location)) - (tlf-number (sb-di::code-location-toplevel-form-offset cloc)) - (form-number (sb-di::code-location-form-number cloc))) - (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream) - (let* ((path-table (sb-di::form-number-translations tlf 0)) - (path (cond ((<= (length path-table) form-number) - (warn "inconsistent form-number-translations") - (list 0)) - (t - (reverse (cdr (aref path-table form-number))))))) - (source-path-source-position path tlf pos-map))))) - -(defun string-source-position (code-location string) - (with-input-from-string (s string) - (stream-source-position code-location s))) - -;;; source-path-file-position and friends are in source-path-parser - -(defimplementation frame-source-location (index) - (converting-errors-to-error-location - (code-location-source-location - (sb-di:frame-code-location (nth-frame index))))) - -(defvar *keep-non-valid-locals* nil) - -(defun frame-debug-vars (frame) - "Return a vector of debug-variables in frame." - (let* ((all-vars (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame))) - (loc (sb-di:frame-code-location frame)) - (vars (if *keep-non-valid-locals* - all-vars - (remove-if (lambda (var) - (ecase (sb-di:debug-var-validity var loc) - (:valid nil) - ((:invalid :unknown) t))) - all-vars))) - more-context - more-count) - (values (when vars - (loop for v across vars - unless - (case (debug-var-info v) - (:more-context - (setf more-context (debug-var-value v frame loc)) - t) - (:more-count - (setf more-count (debug-var-value v frame loc)) - t)) - collect v)) - more-context more-count))) - -(defun debug-var-value (var frame location) - (ecase (sb-di:debug-var-validity var location) - (:valid (sb-di:debug-var-value var frame)) - ((:invalid :unknown) ':))) - -(defun debug-var-info (var) - ;; Introduced by SBCL 1.0.49.76. - (let ((s (find-symbol "DEBUG-VAR-INFO" :sb-di))) - (when (and s (fboundp s)) - (funcall s var)))) - -(defimplementation frame-locals (index) - (let* ((frame (nth-frame index)) - (loc (sb-di:frame-code-location frame))) - (multiple-value-bind (vars more-context more-count) - (frame-debug-vars frame) - (let ((locals - (loop for v in vars - collect - (list :name (sb-di:debug-var-symbol v) - :id (sb-di:debug-var-id v) - :value (debug-var-value v frame loc))))) - (if (and more-context more-count) - (append locals - (list - (list :name - ;; Since SBCL 1.0.49.76 PREPROCESS-FOR-EVAL understands SB-DEBUG::MORE - ;; specially. - (or (find-symbol "MORE" :sb-debug) 'more) - :id 0 - :value (multiple-value-list - (sb-c:%more-arg-values - more-context - 0 more-count))))) - locals))))) - -(defimplementation frame-var-value (frame var) - (let ((frame (nth-frame frame))) - (multiple-value-bind (vars more-context more-count) - (frame-debug-vars frame) - (let* ((loc (sb-di:frame-code-location frame)) - (dvar (if (= var (length vars)) - ;; If VAR is out of bounds, it must be the fake var - ;; we made up for &MORE. - (return-from frame-var-value - (multiple-value-list (sb-c:%more-arg-values - more-context - 0 more-count))) - (nth var vars)))) - (debug-var-value dvar frame loc))))) - -(defimplementation frame-catch-tags (index) - (mapcar #'car (sb-di:frame-catches (nth-frame index)))) - -(defimplementation eval-in-frame (form index) - (let ((frame (nth-frame index))) - (funcall (the function - (sb-di:preprocess-for-eval form - (sb-di:frame-code-location frame))) - frame))) - -(defimplementation frame-package (frame-number) - (let* ((frame (nth-frame frame-number)) - (fun (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame)))) - (when fun - (let ((name (function-name fun))) - (typecase name - (null nil) - (symbol (symbol-package name)) - ((cons (eql setf) (cons symbol)) (symbol-package (cadr name)))))))) - -(defun frame-args-as-list (frame) - (apply #'sb-debug::frame-args-as-list - frame - (if (sbcl-version>= 2 3 0) - '(100) - '()))) - -#+#.(micros/sbcl::sbcl-with-restart-frame) -(progn - (defimplementation return-from-frame (index form) - (let* ((frame (nth-frame index))) - (cond ((sb-debug:frame-has-debug-tag-p frame) - (let ((values (multiple-value-list (eval-in-frame form index)))) - (sb-debug:unwind-to-frame-and-call frame - (lambda () - (values-list values))))) - (t (format nil "Cannot return from frame: ~S" frame))))) - - (defimplementation restart-frame (index) - (let ((frame (nth-frame index))) - (when (sb-debug:frame-has-debug-tag-p frame) - (multiple-value-bind (fname args) (sb-debug::frame-call frame) - (multiple-value-bind (fun arglist) - (if (and (sb-int:legal-fun-name-p fname) (fboundp fname)) - (values (fdefinition fname) args) - (values (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame)) - (frame-args-as-list frame))) - (when (functionp fun) - (sb-debug:unwind-to-frame-and-call - frame - (lambda () - ;; Ensure TCO. - (declare (optimize (debug 0))) - (apply fun arglist))))))) - (format nil "Cannot restart frame: ~S" frame)))) - -;; FIXME: this implementation doesn't unwind the stack before -;; re-invoking the function, but it's better than no implementation at -;; all. -#-#.(micros/sbcl::sbcl-with-restart-frame) -(progn - (defun sb-debug-catch-tag-p (tag) - (and (symbolp tag) - (not (symbol-package tag)) - (string= tag :sb-debug-catch-tag))) - - (defimplementation return-from-frame (index form) - (let* ((frame (nth-frame index)) - (probe (assoc-if #'sb-debug-catch-tag-p - (sb-di::frame-catches frame)))) - (cond (probe (throw (car probe) (eval-in-frame form index))) - (t (format nil "Cannot return from frame: ~S" frame))))) - - (defimplementation restart-frame (index) - (let ((frame (nth-frame index))) - (return-from-frame index (sb-debug::frame-call-as-list frame))))) - -;;;;; reference-conditions - -(defimplementation print-condition (condition stream) - (let ((sb-int:*print-condition-references* nil)) - (princ condition stream))) - - -;;;; Profiling - -(defimplementation profile (fname) - (when fname (eval `(sb-profile:profile ,fname)))) - -(defimplementation unprofile (fname) - (when fname (eval `(sb-profile:unprofile ,fname)))) - -(defimplementation unprofile-all () - (sb-profile:unprofile) - "All functions unprofiled.") - -(defimplementation profile-report () - (sb-profile:report)) - -(defimplementation profile-reset () - (sb-profile:reset) - "Reset profiling counters.") - -(defimplementation profiled-functions () - (sb-profile:profile)) - -(defimplementation profile-package (package callers methods) - (declare (ignore callers methods)) - (eval `(sb-profile:profile ,(package-name (find-package package))))) - - -;;;; Inspector - -(defmethod emacs-inspect ((o t)) - (cond ((sb-di::indirect-value-cell-p o) - (label-value-line* (:value (sb-kernel:value-cell-ref o)))) - (t - (multiple-value-bind (text label parts) (sb-impl::inspected-parts o) - (list* (string-right-trim '(#\Newline) text) - '(:newline) - (if label - (loop for (l . v) in parts - append (label-value-line l v)) - (loop for value in parts - for i from 0 - append (label-value-line i value)))))))) - -(defmethod emacs-inspect ((o function)) - (cond ((sb-kernel:simple-fun-p o) - (label-value-line* - (:name (sb-kernel:%simple-fun-name o)) - (:arglist (sb-kernel:%simple-fun-arglist o)) - (:type (sb-kernel:%simple-fun-type o)) - (:code (sb-kernel:fun-code-header o)))) - ((sb-kernel:closurep o) - (append - (label-value-line :function (sb-kernel:%closure-fun o)) - `("Closed over values:" (:newline)) - (loop for i below (1- (sb-kernel:get-closure-length o)) - append (label-value-line - i (sb-kernel:%closure-index-ref o i))))) - (t (call-next-method o)))) - -(defmethod emacs-inspect ((o sb-kernel:code-component)) - (append - (label-value-line* - (:code-size (sb-kernel:%code-code-size o)) - (:debug-info (sb-kernel:%code-debug-info o))) - `("Constants:" (:newline)) - (loop for i from sb-vm:code-constants-offset - below - (#.(micros/backend:choose-symbol 'sb-kernel 'code-header-words - 'sb-kernel 'get-header-data) - o) - append (label-value-line i (sb-kernel:code-header-ref o i))) - `("Code:" (:newline) - ,(with-output-to-string (s) - (sb-disassem:disassemble-code-component o :stream s))))) - -(defmethod emacs-inspect ((o sb-ext:weak-pointer)) - (label-value-line* - (:value (sb-ext:weak-pointer-value o)))) - -(defmethod emacs-inspect ((o sb-kernel:fdefn)) - (label-value-line* - (:name (sb-kernel:fdefn-name o)) - (:function (sb-kernel:fdefn-fun o)))) - -(defmethod emacs-inspect :around ((o generic-function)) - (append - (call-next-method) - (label-value-line* - (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o)) - (:initial-methods (sb-pcl::generic-function-initial-methods o)) - ))) - - -;;;; Multiprocessing - -#+(and sb-thread - #.(micros/backend:with-symbol "THREAD-NAME" "SB-THREAD")) -(progn - (defvar *thread-id-counter* 0) - - (defvar *thread-id-counter-lock* - (sb-thread:make-mutex :name "thread id counter lock")) - - (defun next-thread-id () - (sb-thread:with-mutex (*thread-id-counter-lock*) - (incf *thread-id-counter*))) - - (defparameter *thread-id-map* (make-hash-table)) - - ;; This should be a thread -> id map but as weak keys are not - ;; supported it is id -> map instead. - (defvar *thread-id-map-lock* - (sb-thread:make-mutex :name "thread id map lock")) - - (defimplementation spawn (fn &key name) - (sb-thread:make-thread fn :name name)) - - (defimplementation thread-id (thread) - (block thread-id - (sb-thread:with-mutex (*thread-id-map-lock*) - (loop for id being the hash-key in *thread-id-map* - using (hash-value thread-pointer) - do - (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer))) - (cond ((null maybe-thread) - ;; the value is gc'd, remove it manually - (remhash id *thread-id-map*)) - ((eq thread maybe-thread) - (return-from thread-id id))))) - ;; lazy numbering - (let ((id (next-thread-id))) - (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread)) - id)))) - - (defimplementation find-thread (id) - (sb-thread:with-mutex (*thread-id-map-lock*) - (let ((thread-pointer (gethash id *thread-id-map*))) - (if thread-pointer - (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer))) - (if maybe-thread - maybe-thread - ;; the value is gc'd, remove it manually - (progn - (remhash id *thread-id-map*) - nil))) - nil)))) - - (defimplementation thread-name (thread) - ;; sometimes the name is not a string (e.g. NIL) - (princ-to-string (sb-thread:thread-name thread))) - - (defimplementation thread-status (thread) - (if (sb-thread:thread-alive-p thread) - "Running" - "Stopped")) - - (defimplementation make-lock (&key name) - (sb-thread:make-mutex :name name)) - - (defimplementation call-with-lock-held (lock function) - (declare (type function function)) - (sb-thread:with-recursive-lock (lock) (funcall function))) - - (defimplementation current-thread () - sb-thread:*current-thread*) - - (defimplementation all-threads () - (sb-thread:list-all-threads)) - - (defimplementation interrupt-thread (thread fn) - (sb-thread:interrupt-thread thread fn)) - - (defimplementation kill-thread (thread) - (sb-thread:terminate-thread thread)) - - (defimplementation thread-alive-p (thread) - (sb-thread:thread-alive-p thread)) - - (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock")) - (defvar *mailboxes* (list)) - (declaim (type list *mailboxes*)) - - (defstruct (mailbox (:conc-name mailbox.)) - thread - (mutex (sb-thread:make-mutex)) - (waitqueue (sb-thread:make-waitqueue)) - (queue '() :type list)) - - (defun mailbox (thread) - "Return THREAD's mailbox." - (sb-thread:with-mutex (*mailbox-lock*) - (or (find thread *mailboxes* :key #'mailbox.thread) - (let ((mb (make-mailbox :thread thread))) - (push mb *mailboxes*) - mb)))) - - (defimplementation wake-thread (thread) - (let* ((mbox (mailbox thread)) - (mutex (mailbox.mutex mbox))) - (sb-thread:with-recursive-lock (mutex) - (sb-thread:condition-broadcast (mailbox.waitqueue mbox))))) - - (defimplementation send (thread message) - (let* ((mbox (mailbox thread)) - (mutex (mailbox.mutex mbox))) - (sb-thread:with-mutex (mutex) - (setf (mailbox.queue mbox) - (nconc (mailbox.queue mbox) (list message))) - (sb-thread:condition-broadcast (mailbox.waitqueue mbox))))) - - (defimplementation receive-if (test &optional timeout) - (let* ((mbox (mailbox (current-thread))) - (mutex (mailbox.mutex mbox)) - (waitq (mailbox.waitqueue mbox))) - (assert (or (not timeout) (eq timeout t))) - (loop - (check-slime-interrupts) - (sb-thread:with-mutex (mutex) - (let* ((q (mailbox.queue mbox)) - (tail (member-if test q))) - (when tail - (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) - (return (car tail)))) - (when (eq timeout t) (return (values nil t))) - (sb-thread:condition-wait waitq mutex))))) - - (let ((alist '()) - (mutex (sb-thread:make-mutex :name "register-thread"))) - - (defimplementation register-thread (name thread) - (declare (type symbol name)) - (sb-thread:with-mutex (mutex) - (etypecase thread - (null - (setf alist (delete name alist :key #'car))) - (sb-thread:thread - (let ((probe (assoc name alist))) - (cond (probe (setf (cdr probe) thread)) - (t (setf alist (acons name thread alist)))))))) - nil) - - (defimplementation find-registered (name) - (sb-thread:with-mutex (mutex) - (cdr (assoc name alist)))))) - -(defimplementation quit-lisp () - #+#.(micros/backend:with-symbol 'exit 'sb-ext) - (sb-ext:exit) - #-#.(micros/backend:with-symbol 'exit 'sb-ext) - (progn - #+sb-thread - (dolist (thread (remove (current-thread) (all-threads))) - (ignore-errors (sb-thread:terminate-thread thread))) - (sb-ext:quit))) - - - -;;Trace implementations -;;In SBCL, we have: -;; (trace ) -;; (trace :methods ') ;to trace all methods of the gf -;; (trace (method ? (+))) -;; can be a normal name or a (setf name) - -(defun toggle-trace-aux (fspec &rest args) - (cond ((member fspec (eval '(trace)) :test #'equal) - (eval `(untrace ,fspec)) - (format nil "~S is now untraced." fspec)) - (t - (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args)) - (format nil "~S is now traced." fspec)))) - -(defun process-fspec (fspec) - (cond ((consp fspec) - (ecase (first fspec) - ((:defun :defgeneric) (second fspec)) - ((:defmethod) `(method ,@(rest fspec))) - ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec))) - ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec))))) - (t - fspec))) - -(defimplementation toggle-trace (spec) - (ecase (car spec) - ((setf) - (toggle-trace-aux spec)) - ((:defmethod) - (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec))))) - ((:defgeneric) - (toggle-trace-aux (second spec) :methods t)) - ((:call) - (destructuring-bind (caller callee) (cdr spec) - (toggle-trace-aux callee :wherein (list (process-fspec caller))))))) - -;;; Weak datastructures - -(defimplementation make-weak-key-hash-table (&rest args) - #+#.(micros/sbcl::sbcl-with-weak-hash-tables) - (apply #'make-hash-table :weakness :key args) - #-#.(micros/sbcl::sbcl-with-weak-hash-tables) - (apply #'make-hash-table args)) - -(defimplementation make-weak-value-hash-table (&rest args) - #+#.(micros/sbcl::sbcl-with-weak-hash-tables) - (apply #'make-hash-table :weakness :value args) - #-#.(micros/sbcl::sbcl-with-weak-hash-tables) - (apply #'make-hash-table args)) - -(defimplementation hash-table-weakness (hashtable) - #+#.(micros/sbcl::sbcl-with-weak-hash-tables) - (sb-ext:hash-table-weakness hashtable)) - -;;; Floating point - -(defimplementation float-nan-p (float) - (sb-ext:float-nan-p float)) - -(defimplementation float-infinity-p (float) - (sb-ext:float-infinity-p float)) - -#-win32 -(defimplementation save-image (filename &optional restart-function) - (flet ((restart-sbcl () - (sb-debug::enable-debugger) - (setf sb-impl::*descriptor-handlers* nil) - (funcall restart-function))) - (let ((pid (sb-posix:fork))) - (cond ((= pid 0) - (sb-debug::disable-debugger) - (apply #'sb-ext:save-lisp-and-die filename - (when restart-function - (list :toplevel #'restart-sbcl)))) - (t - (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0) - (assert (= pid rpid)) - (assert (and (sb-posix:wifexited status) - (zerop (sb-posix:wexitstatus status)))))))))) - -#+unix -(progn - (sb-alien:define-alien-routine ("execv" sys-execv) sb-alien:int - (program sb-alien:c-string) - (argv (* sb-alien:c-string))) - - (defun execv (program args) - "Replace current executable with another one." - (let ((a-args (sb-alien:make-alien sb-alien:c-string - (+ 1 (length args))))) - (unwind-protect - (progn - (loop for index from 0 by 1 - and item in (append args '(nil)) - do (setf (sb-alien:deref a-args index) - item)) - (when (minusp - (sys-execv program a-args)) - (error "execv(3) returned."))) - (sb-alien:free-alien a-args)))) - - (defun runtime-pathname () - #+#.(micros/backend:with-symbol - '*runtime-pathname* 'sb-ext) - sb-ext:*runtime-pathname* - #-#.(micros/backend:with-symbol - '*runtime-pathname* 'sb-ext) - (car sb-ext:*posix-argv*)) - - (defimplementation exec-image (image-file args) - (loop with fd-arg = - (loop for arg in args - and key = "" then arg - when (string-equal key "--swank-fd") - return (parse-integer arg)) - for my-fd from 3 to 1024 - when (/= my-fd fd-arg) - do (ignore-errors (sb-posix:fcntl my-fd sb-posix:f-setfd 1))) - (let* ((self-string (pathname-to-filename (runtime-pathname)))) - (execv - self-string - (apply 'list self-string "--core" image-file args))))) - -(defimplementation make-fd-stream (fd external-format) - (sb-sys:make-fd-stream fd :input t :output t - :element-type 'character - :buffering :full - :dual-channel-p t - :external-format external-format)) - -#-win32 -(defimplementation background-save-image (filename &key restart-function - completion-function) - (flet ((restart-sbcl () - (sb-debug::enable-debugger) - (setf sb-impl::*descriptor-handlers* nil) - (funcall restart-function))) - (multiple-value-bind (pipe-in pipe-out) (sb-posix:pipe) - (let ((pid (sb-posix:fork))) - (cond ((= pid 0) - (sb-posix:close pipe-in) - (sb-debug::disable-debugger) - (apply #'sb-ext:save-lisp-and-die filename - (when restart-function - (list :toplevel #'restart-sbcl)))) - (t - (sb-posix:close pipe-out) - (sb-sys:add-fd-handler - pipe-in :input - (lambda (fd) - (sb-sys:invalidate-descriptor fd) - (sb-posix:close fd) - (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0) - (assert (= pid rpid)) - (assert (sb-posix:wifexited status)) - (funcall completion-function - (zerop (sb-posix:wexitstatus status)))))))))))) - -(pushnew 'deinit-log-output sb-ext:*save-hooks*) - - -;;;; wrap interface implementation - -(defun sbcl-version>= (&rest subversions) - #+#.(micros/backend:with-symbol 'assert-version->= 'sb-ext) - (values (ignore-errors (apply #'sb-ext:assert-version->= subversions) t)) - #-#.(micros/backend:with-symbol 'assert-version->= 'sb-ext) - nil) - -(defimplementation wrap (spec indicator &key before after replace) - (when (wrapped-p spec indicator) - (warn "~a already wrapped with indicator ~a, unwrapping first" - spec indicator) - (sb-int:unencapsulate spec indicator)) - (sb-int:encapsulate spec indicator - #-#.(micros/backend:with-symbol 'arg-list 'sb-int) - (lambda (function &rest args) - (sbcl-wrap spec before after replace function args)) - #+#.(micros/backend:with-symbol 'arg-list 'sb-int) - (if (sbcl-version>= 1 1 16) - (lambda () - (sbcl-wrap spec before after replace - (symbol-value 'sb-int:basic-definition) - (symbol-value 'sb-int:arg-list))) - `(sbcl-wrap ',spec ,before ,after ,replace - (symbol-value 'sb-int:basic-definition) - (symbol-value 'sb-int:arg-list))))) - -(defimplementation unwrap (spec indicator) - (sb-int:unencapsulate spec indicator)) - -(defimplementation wrapped-p (spec indicator) - (sb-int:encapsulated-p spec indicator)) - -(defun sbcl-wrap (spec before after replace function args) - (declare (ignore spec)) - (let (retlist completed) - (unwind-protect - (progn - (when before - (funcall before args)) - (setq retlist (multiple-value-list (if replace - (funcall replace - args) - (apply function args)))) - (setq completed t) - (values-list retlist)) - (when after - (funcall after (if completed retlist :exited-non-locally)))))) - -#+#.(micros/backend:with-symbol 'comma-expr 'sb-impl) -(progn - (defmethod sexp-in-bounds-p ((s sb-impl::comma) i) - (sexp-in-bounds-p (sb-impl::comma-expr s) i)) - - (defmethod sexp-ref ((s sb-impl::comma) i) - (sexp-ref (sb-impl::comma-expr s) i))) diff --git a/lib/micros/swank/source-file-cache.lisp b/lib/micros/swank/source-file-cache.lisp deleted file mode 100644 index 3ae9d7647..000000000 --- a/lib/micros/swank/source-file-cache.lisp +++ /dev/null @@ -1,136 +0,0 @@ -;;;; Source-file cache -;;; -;;; To robustly find source locations in CMUCL and SBCL it's useful to -;;; have the exact source code that the loaded code was compiled from. -;;; In this source we can accurately find the right location, and from -;;; that location we can extract a "snippet" of code to show what the -;;; definition looks like. Emacs can use this snippet in a best-match -;;; search to locate the right definition, which works well even if -;;; the buffer has been modified. -;;; -;;; The idea is that if a definition previously started with -;;; `(define-foo bar' then it probably still does. -;;; -;;; Whenever we see that the file on disk has the same -;;; `file-write-date' as a location we're looking for we cache the -;;; whole file inside Lisp. That way we will still have the matching -;;; version even if the file is later modified on disk. If the file is -;;; later recompiled and reloaded then we replace our cache entry. -;;; -;;; This code has been placed in the Public Domain. All warranties -;;; are disclaimed. - -(defpackage micros/source-file-cache - (:use cl) - (:import-from micros/backend - defimplementation buffer-first-change - guess-external-format - find-external-format) - (:export - get-source-code - source-cache-get ;FIXME: isn't it odd that both are exported? - - *source-snippet-size* - read-snippet - read-snippet-from-string - )) - -(in-package micros/source-file-cache) - -(defvar *cache-sourcecode* t - "When true complete source files are cached. -The cache is used to keep known good copies of the source text which -correspond to the loaded code. Finding definitions is much more -reliable when the exact source is available, so we cache it in case it -gets edited on disk later.") - -(defvar *source-file-cache* (make-hash-table :test 'equal) - "Cache of source file contents. -Maps from truename to source-cache-entry structure.") - -(defstruct (source-cache-entry - (:conc-name source-cache-entry.) - (:constructor make-source-cache-entry (text date))) - text date) - -(defimplementation buffer-first-change (filename) - "Load a file into the cache when the user modifies its buffer. -This is a win if the user then saves the file and tries to M-. into it." - (unless (source-cached-p filename) - (ignore-errors - (source-cache-get filename (file-write-date filename)))) - nil) - -(defun get-source-code (filename code-date) - "Return the source code for FILENAME as written on DATE in a string. -If the exact version cannot be found then return the current one from disk." - (or (source-cache-get filename code-date) - (read-file filename))) - -(defun source-cache-get (filename date) - "Return the source code for FILENAME as written on DATE in a string. -Return NIL if the right version cannot be found." - (when *cache-sourcecode* - (let ((entry (gethash filename *source-file-cache*))) - (cond ((and entry (equal date (source-cache-entry.date entry))) - ;; Cache hit. - (source-cache-entry.text entry)) - ((or (null entry) - (not (equal date (source-cache-entry.date entry)))) - ;; Cache miss. - (if (equal (file-write-date filename) date) - ;; File on disk has the correct version. - (let ((source (read-file filename))) - (setf (gethash filename *source-file-cache*) - (make-source-cache-entry source date)) - source) - nil)))))) - -(defun source-cached-p (filename) - "Is any version of FILENAME in the source cache?" - (if (gethash filename *source-file-cache*) t)) - -(defun read-file (filename) - "Return the entire contents of FILENAME as a string." - (with-open-file (s filename :direction :input - :external-format (or (guess-external-format filename) - (find-external-format "latin-1") - :default)) - (let* ((string (make-string (file-length s))) - (length (read-sequence string s))) - (subseq string 0 length)))) - -;;;; Snippets - -(defvar *source-snippet-size* 256 - "Maximum number of characters in a snippet of source code. -Snippets at the beginning of definitions are used to tell Emacs what -the definitions looks like, so that it can accurately find them by -text search.") - -(defun read-snippet (stream &optional position) - "Read a string of upto *SOURCE-SNIPPET-SIZE* characters from STREAM. -If POSITION is given, set the STREAM's file position first." - (when position - (file-position stream position)) - #+sbcl (skip-comments-and-whitespace stream) - (read-upto-n-chars stream *source-snippet-size*)) - -(defun read-snippet-from-string (string &optional position) - (with-input-from-string (s string) - (read-snippet s position))) - -(defun skip-comments-and-whitespace (stream) - (case (peek-char nil stream nil nil) - ((#\Space #\Tab #\Newline #\Linefeed #\Page) - (read-char stream) - (skip-comments-and-whitespace stream)) - (#\; - (read-line stream) - (skip-comments-and-whitespace stream)))) - -(defun read-upto-n-chars (stream n) - "Return a string of upto N chars from STREAM." - (let* ((string (make-string n)) - (chars (read-sequence string stream))) - (subseq string 0 chars))) diff --git a/lib/micros/swank/source-path-parser.lisp b/lib/micros/swank/source-path-parser.lisp deleted file mode 100644 index f3263dbd7..000000000 --- a/lib/micros/swank/source-path-parser.lisp +++ /dev/null @@ -1,242 +0,0 @@ -;;;; Source-paths - -;;; CMUCL/SBCL use a data structure called "source-path" to locate -;;; subforms. The compiler assigns a source-path to each form in a -;;; compilation unit. Compiler notes usually contain the source-path -;;; of the error location. -;;; -;;; Compiled code objects don't contain source paths, only the -;;; "toplevel-form-number" and the (sub-) "form-number". To get from -;;; the form-number to the source-path we need the entire toplevel-form -;;; (i.e. we have to read the source code). CMUCL has already some -;;; utilities to do this translation, but we use some extended -;;; versions, because we need more exact position info. Apparently -;;; Hemlock is happy with the position of the toplevel-form; we also -;;; need the position of subforms. -;;; -;;; We use a special readtable to get the positions of the subforms. -;;; The readtable stores the start and end position for each subform in -;;; hashtable for later retrieval. -;;; -;;; This code has been placed in the Public Domain. All warranties -;;; are disclaimed. - -;;; Taken from swank-cmucl.lisp, by Helmut Eller - -(defpackage micros/source-path-parser - (:use cl) - (:export - read-source-form - source-path-string-position - source-path-file-position - source-path-source-position - - sexp-in-bounds-p - sexp-ref) - (:shadow ignore-errors)) - -(in-package micros/source-path-parser) - -;; Some test to ensure the required conformance -(let ((rt (copy-readtable nil))) - (assert (or (not (get-macro-character #\space rt)) - (nth-value 1 (get-macro-character #\space rt)))) - (assert (not (get-macro-character #\\ rt)))) - -(eval-when (:compile-toplevel) - (defmacro ignore-errors (&rest forms) - ;;`(progn . ,forms) ; for debugging - `(cl:ignore-errors . ,forms))) - -(defun make-sharpdot-reader (orig-sharpdot-reader) - (lambda (s c n) - ;; We want things like M-. to work regardless of any #.-fu in - ;; the source file that is to be visited. (For instance, when a - ;; file contains #. forms referencing constants that do not - ;; currently exist in the image.) - (ignore-errors (funcall orig-sharpdot-reader s c n)))) - -(defun make-source-recorder (fn source-map) - "Return a macro character function that does the same as FN, but -additionally stores the result together with the stream positions -before and after of calling FN in the hashtable SOURCE-MAP." - (lambda (stream char) - (let ((start (1- (file-position stream))) - (values (multiple-value-list (funcall fn stream char))) - (end (file-position stream))) - #+(or) - (format t "[~D \"~{~A~^, ~}\" ~D ~D ~S]~%" - start values end (char-code char) char) - (when values - (destructuring-bind (&optional existing-start &rest existing-end) - (car (gethash (car values) source-map)) - ;; Some macros may return what a sub-call to another macro - ;; produced, e.g. "#+(and) (a)" may end up saving (a) twice, - ;; once from #\# and once from #\(. If the saved form - ;; is a subform, don't save it again. - (unless (and existing-start existing-end - (<= start existing-start end) - (<= start existing-end end)) - (push (cons start end) (gethash (car values) source-map))))) - (values-list values)))) - -(defun make-source-recording-readtable (readtable source-map) - (declare (type readtable readtable) (type hash-table source-map)) - "Return a source position recording copy of READTABLE. -The source locations are stored in SOURCE-MAP." - (flet ((install-special-sharpdot-reader (rt) - (let ((fun (ignore-errors - (get-dispatch-macro-character #\# #\. rt)))) - (when fun - (let ((wrapper (make-sharpdot-reader fun))) - (set-dispatch-macro-character #\# #\. wrapper rt))))) - (install-wrappers (rt) - (dotimes (code 128) - (let ((char (code-char code))) - (multiple-value-bind (fun nt) (get-macro-character char rt) - (when fun - (let ((wrapper (make-source-recorder fun source-map))) - (set-macro-character char wrapper nt rt)))))))) - (let ((rt (copy-readtable readtable))) - (install-special-sharpdot-reader rt) - (install-wrappers rt) - rt))) - -;; FIXME: try to do this with *READ-SUPPRESS* = t to avoid interning. -;; Should be possible as we only need the right "list structure" and -;; not the right atoms. -(defun read-and-record-source-map (stream) - "Read the next object from STREAM. -Return the object together with a hashtable that maps -subexpressions of the object to stream positions." - (let* ((source-map (make-hash-table :test #'eq)) - (*readtable* (make-source-recording-readtable *readtable* source-map)) - (*read-suppress* nil) - (start (file-position stream)) - (form (ignore-errors (read stream))) - (end (file-position stream))) - ;; ensure that at least FORM is in the source-map - (unless (gethash form source-map) - (push (cons start end) (gethash form source-map))) - (values form source-map))) - -(defun starts-with-p (string prefix) - (declare (type string string prefix)) - (not (mismatch string prefix - :end1 (min (length string) (length prefix)) - :test #'char-equal))) - -(defun extract-package (line) - (declare (type string line)) - (let ((name (cadr (read-from-string line)))) - (find-package name))) - -#+(or) -(progn - (assert (extract-package "(in-package cl)")) - (assert (extract-package "(cl:in-package cl)")) - (assert (extract-package "(in-package \"CL\")")) - (assert (extract-package "(in-package #:cl)"))) - -;; FIXME: do something cleaner than this. -(defun readtable-for-package (package) - ;; KLUDGE: due to the load order we can't reference the swank - ;; package. - (funcall (read-from-string "micros::guess-buffer-readtable") - (string-upcase (package-name package)))) - -;; Search STREAM for a "(in-package ...)" form. Use that to derive -;; the values for *PACKAGE* and *READTABLE*. -;; -;; IDEA: move GUESS-READER-STATE to swank.lisp so that all backends -;; use the same heuristic and to avoid the need to access -;; micros::guess-buffer-readtable from here. -(defun guess-reader-state (stream) - (let* ((point (file-position stream)) - (pkg *package*)) - (file-position stream 0) - (loop for line = (read-line stream nil nil) do - (when (not line) (return)) - (when (or (starts-with-p line "(in-package ") - (starts-with-p line "(cl:in-package ")) - (let ((p (extract-package line))) - (when p (setf pkg p))) - (return))) - (file-position stream point) - (values (readtable-for-package pkg) pkg))) - -(defun skip-whitespace (stream) - (peek-char t stream nil nil)) - -;; Skip over N toplevel forms. -(defun skip-toplevel-forms (n stream) - (let ((*read-suppress* t)) - (dotimes (i n) - (read stream)) - (skip-whitespace stream))) - -(defun read-source-form (n stream) - "Read the Nth toplevel form number with source location recording. -Return the form and the source-map." - (multiple-value-bind (*readtable* *package*) (guess-reader-state stream) - (let (#+sbcl - (*features* (append *features* - (symbol-value (find-symbol "+INTERNAL-FEATURES+" 'sb-impl))))) - (skip-toplevel-forms n stream) - (read-and-record-source-map stream)))) - -(defun source-path-stream-position (path stream) - "Search the source-path PATH in STREAM and return its position." - (check-source-path path) - (destructuring-bind (tlf-number . path) path - (multiple-value-bind (form source-map) (read-source-form tlf-number stream) - (source-path-source-position (cons 0 path) form source-map)))) - -(defun check-source-path (path) - (unless (and (consp path) - (every #'integerp path)) - (error "The source-path ~S is not valid." path))) - -(defun source-path-string-position (path string) - (with-input-from-string (s string) - (source-path-stream-position path s))) - -(defun source-path-file-position (path filename) - ;; We go this long way round, and don't directly operate on the file - ;; stream because FILE-POSITION (used above) is not totally savy even - ;; on file character streams; on SBCL, FILE-POSITION returns the binary - ;; offset, and not the character offset---screwing up on Unicode. - (let ((toplevel-number (first path)) - (buffer)) - (with-open-file (file filename) - (skip-toplevel-forms (1+ toplevel-number) file) - (let ((endpos (file-position file))) - (setq buffer (make-array (list endpos) :element-type 'character - :initial-element #\Space)) - (assert (file-position file 0)) - (read-sequence buffer file :end endpos))) - (source-path-string-position path buffer))) - -(defgeneric sexp-in-bounds-p (sexp i) - (:method ((list list) i) - (< i (loop for e on list - count t))) - (:method ((sexp t) i) nil)) - -(defgeneric sexp-ref (sexp i) - (:method ((s list) i) (elt s i))) - -(defun source-path-source-position (path form source-map) - "Return the start position of PATH from FORM and SOURCE-MAP. All -subforms along the path are considered and the start and end position -of the deepest (i.e. smallest) possible form is returned." - ;; compute all subforms along path - (let ((forms (loop for i in path - for f = form then (if (sexp-in-bounds-p f i) - (sexp-ref f i)) - collect f))) - ;; select the first subform present in source-map - (loop for form in (nreverse forms) - for ((start . end) . rest) = (gethash form source-map) - when (and start end (not rest)) - return (return (values start end))))) diff --git a/modes/lisp-mode/apropos-mode.lisp b/modes/lisp-mode/apropos-mode.lisp index 56caecbea..512748dc1 100644 --- a/modes/lisp-mode/apropos-mode.lisp +++ b/modes/lisp-mode/apropos-mode.lisp @@ -35,7 +35,7 @@ (defun lisp-apropos-internal (string only-external-p package case-sensitive-p) (show-apropos (lisp-eval - `(swank:apropos-list-for-emacs ,string + `(micros:apropos-list-for-emacs ,string ,only-external-p ,case-sensitive-p ,package)) diff --git a/modes/lisp-mode/autodoc.lisp b/modes/lisp-mode/autodoc.lisp index a17e2ca60..9fa0c5a86 100644 --- a/modes/lisp-mode/autodoc.lisp +++ b/modes/lisp-mode/autodoc.lisp @@ -9,7 +9,7 @@ (let ((autodoc-symbol nil)) (defun autodoc-symbol () (or autodoc-symbol - (setf autodoc-symbol (intern "AUTODOC" :swank))))) + (setf autodoc-symbol (intern "AUTODOC" :micros))))) (defun highlighting-marker (point) (let ((marker-start "===> ") @@ -27,14 +27,14 @@ (insert-string start matched-string :attribute 'region))))))) (defun autodoc (function) - (let ((context (lem-lisp-syntax:parse-for-swank-autodoc (current-point)))) + (let ((context (lem-lisp-syntax:parse-for-autodoc (current-point)))) (lisp-eval-async `(,(autodoc-symbol) ',context) (lambda (doc) (trivia:match doc ((list doc _) (unless (eq doc :not-available) - (let* ((buffer (make-buffer "*swank:autodoc-fontity*" + (let* ((buffer (make-buffer "*micros:autodoc-fontity*" :temporary t :enable-undo-p nil))) (with-point ((point (buffer-point buffer) :right-inserting)) (erase-buffer buffer) diff --git a/modes/lisp-mode/inspector.lisp b/modes/lisp-mode/inspector.lisp index fc881ecb8..d1d2800f1 100644 --- a/modes/lisp-mode/inspector.lisp +++ b/modes/lisp-mode/inspector.lisp @@ -37,8 +37,8 @@ (define-command lisp-inspect (string) ((or (symbol-string-at-point (current-point)) (prompt-for-sexp "Inspect value (evaluated): "))) - (lisp-eval-async `(swank:init-inspector - (format nil "(quote ~a)" ,string)) + (lisp-eval-async `(micros:init-inspector + (format nil "(quote ~a)" ,string)) 'open-inspector)) (defun inspector-buffer () @@ -118,16 +118,16 @@ (lambda () (ecase type ((:part) - (lisp-eval-async `(swank:inspect-nth-part ,value) + (lisp-eval-async `(micros:inspect-nth-part ,value) 'inspector-new-opener)) ((:range) (inspector-fetch-more value)) ((:action) - (lisp-eval-async `(swank::inspector-call-nth-action ,value) + (lisp-eval-async `(micros::inspector-call-nth-action ,value) 'inspector-opener))))) (define-command lisp-inspector-pop () () - (lisp-eval-async `(swank:inspector-pop) + (lisp-eval-async `(micros:inspector-pop) (lambda (result) (cond (result (open-inspector result (pop *inspector-mark-stack*))) @@ -135,7 +135,7 @@ (display-message "No previous object")))))) (define-command lisp-inspector-next () () - (let ((result (lisp-eval `(swank:inspector-next)))) + (let ((result (lisp-eval `(micros:inspector-next)))) (cond (result (push (inspector-position (current-point)) *inspector-mark-stack*) (open-inspector result)) @@ -143,7 +143,7 @@ (display-message "No next object"))))) (define-command lisp-inspector-quit () () - (lisp-eval-async `(swank:quit-inspector)) + (lisp-eval-async `(micros:quit-inspector)) (quit-active-window t)) ;; slime-find-inspectable-object @@ -151,7 +151,7 @@ ;; slime-inspector-previous-inspectable-object (define-command lisp-inspector-describe () () - (lisp-eval-describe `(swank:describe-inspectee))) + (lisp-eval-describe `(micros:describe-inspectee))) (defun inspector-get-part () (let* ((button (button-at (current-point))) @@ -161,28 +161,28 @@ (define-command lisp-inspector-pprint (part) ((inspector-get-part)) - (lisp-eval-describe `(swank:pprint-inspector-part ,part))) + (lisp-eval-describe `(micros:pprint-inspector-part ,part))) (define-command lisp-inspector-eval (string) ((prompt-for-sexp "Inspector eval: ")) - (eval-with-transcript `(swank:inspector-eval ,string))) + (eval-with-transcript `(micros:inspector-eval ,string))) (define-command lisp-inspector-history () () - (lisp-eval-describe `(swank:inspector-history))) + (lisp-eval-describe `(micros:inspector-history))) (define-command lisp-inspector-show-source (part) ((inspector-get-part)) - (lisp-eval-async `(swank:find-source-location-for-emacs '(:inspector ,part)) + (lisp-eval-async `(micros:find-source-location-for-emacs '(:inspector ,part)) #'show-source-location)) (define-command lisp-inspector-reinspect () () - (lisp-eval-async '(swank:inspector-reinspect) + (lisp-eval-async '(micros:inspector-reinspect) (let ((pos (inspector-position (current-point)))) (lambda (parts) (open-inspector parts pos))))) (define-command lisp-inspector-toggle-verbose () () - (lisp-eval-async `(swank:inspector-toggle-verbose) + (lisp-eval-async `(micros:inspector-toggle-verbose) (let ((pos (inspector-position (current-point)))) (lambda (parts) (open-inspector parts pos))))) @@ -218,7 +218,7 @@ (destructuring-bind (from to) (inspector-next-range chunk limit prev) (if (and from to) - (lisp-eval-async `(swank:inspector-range ,from ,to) + (lisp-eval-async `(micros:inspector-range ,from ,to) (alexandria:rcurry (lambda (chunk2 chunk1 limit prev cont) (inspector-fetch (inspector-join-chunks chunk1 chunk2) @@ -247,7 +247,7 @@ (t (error "Invalid chunks")))))) (define-command lisp-inspector-copy-down-to-repl () () - (copy-down-to-repl 'swank:inspector-nth-part (inspector-get-part))) + (copy-down-to-repl 'micros:inspector-nth-part (inspector-get-part))) (define-message (:inspect what thread tag) (let ((hook (when (and thread tag) diff --git a/modes/lisp-mode/lem-lisp-mode.asd b/modes/lisp-mode/lem-lisp-mode.asd index 8748de3bf..547466c81 100644 --- a/modes/lisp-mode/lem-lisp-mode.asd +++ b/modes/lisp-mode/lem-lisp-mode.asd @@ -2,7 +2,7 @@ :depends-on ("alexandria" "trivial-types" "usocket" - "swank" + "micros" "trivia" "uiop" "lem-lisp-syntax" @@ -12,7 +12,6 @@ :serial t :components ((:file "test-api") (:file "errors") - (:file "swank-modules") (:file "swank-protocol") (:file "connections") (:file "message-dispatcher") diff --git a/modes/lisp-mode/lisp-mode.lisp b/modes/lisp-mode/lisp-mode.lisp index e565e8d1e..a283cf8bc 100644 --- a/modes/lisp-mode/lisp-mode.lisp +++ b/modes/lisp-mode/lisp-mode.lisp @@ -112,9 +112,9 @@ (defun self-connect () (unless lem-lisp-mode/test-api:*disable-self-connect* (let ((port (lem-socket-utils:random-available-port))) - (log:debug "Starting internal SWANK and connecting to it" swank:*communication-style*) - (let ((swank::*swank-debug-p* nil)) - (swank:create-server :port port :style :spawn)) + (log:debug "Starting internal SWANK and connecting to it" micros:*communication-style*) + (let ((micros::*swank-debug-p* nil)) + (micros:create-server :port port :style :spawn)) (connect-to-swank *localhost* port) (update-buffer-package) (setf *self-connected-port* port)))) @@ -123,7 +123,7 @@ (and (typep connection 'connection) (integerp (self-connected-port)) (member (connection-hostname connection) '("127.0.0.1" "localhost") :test 'equal) - (ignore-errors (equal (connection-pid connection) (swank/backend:getpid))) + (ignore-errors (equal (connection-pid connection) (micros/backend:getpid))) (= (connection-port connection) (self-connected-port)) :self)) @@ -234,16 +234,16 @@ :package package)) (defun re-eval-defvar (string) - (eval-with-transcript `(swank:re-evaluate-defvar ,string))) + (eval-with-transcript `(micros:re-evaluate-defvar ,string))) (defun interactive-eval (string &key (package (current-package))) - (eval-with-transcript `(swank:interactive-eval ,string) :package package)) + (eval-with-transcript `(micros:interactive-eval ,string) :package package)) (defun eval-print (string &optional print-right-margin) (let ((value (lisp-eval (if print-right-margin `(let ((*print-right-margin* ,print-right-margin)) - (swank:eval-and-grab-output ,string)) - `(swank:eval-and-grab-output ,string))))) + (micros:eval-and-grab-output ,string)) + `(micros:eval-and-grab-output ,string))))) (insert-string (current-point) (first value)) (insert-character (current-point) #\newline) (insert-string (current-point) (second value)))) @@ -257,7 +257,7 @@ (check-connection) (let ((package-names (mapcar #'string-downcase (lisp-eval - '(swank:list-all-package-names t))))) + '(micros:list-all-package-names t))))) (string-upcase (prompt-for-string "Package: " :completion-function (lambda (string) @@ -309,7 +309,7 @@ (cond ((string= package-name "")) ((eq (current-buffer) (repl-buffer)) (destructuring-bind (name prompt-string) - (lisp-eval `(swank:set-package ,package-name)) + (lisp-eval `(micros:set-package ,package-name)) (new-package name prompt-string) (lem/listener-mode:refresh-prompt (repl-buffer)))) (t @@ -322,22 +322,22 @@ (save-excursion (setf (current-buffer) repl-buffer) (destructuring-bind (name prompt-string) - (lisp-eval `(swank:set-package ,package)) + (lisp-eval `(micros:set-package ,package)) (new-package name prompt-string))) (start-lisp-repl) (buffer-end (buffer-point repl-buffer)))) (define-command lisp-current-directory () () (message "Current directory: ~a" - (lisp-eval `(swank:default-directory)))) + (lisp-eval `(micros:default-directory)))) (define-command lisp-set-directory (&key directory) () (unless directory (setf directory (prompt-for-directory "New directory: " :directory (buffer-directory)))) (lisp-eval - `(swank:set-default-directory - (swank-backend:filename-to-pathname ,directory)))) + `(micros:set-default-directory + (micros/backend:filename-to-pathname ,directory)))) (define-command lisp-interrupt () () (send-message-string @@ -436,7 +436,7 @@ "Execute the region as Lisp code." (check-connection) (eval-with-transcript - `(swank:interactive-eval-region + `(micros:interactive-eval-region ,(points-to-string start end)))) (define-command lisp-eval-buffer () () @@ -458,7 +458,7 @@ `(if (and (cl:find-package :roswell) (cl:find-symbol (cl:string :load) :roswell)) (uiop:symbol-call :roswell :load ,filename) - (swank:load-file ,filename))) + (micros:load-file ,filename))) :package "CL-USER")))) (defun get-operator-name () @@ -472,7 +472,7 @@ (let ((name (get-operator-name)) (package (current-package))) (when name - (lisp-eval-async `(swank:operator-arglist ,name ,package) + (lisp-eval-async `(micros:operator-arglist ,name ,package) (lambda (arglist) (when arglist (display-message "~A" (ppcre:regex-replace-all "\\s+" arglist " ")))))))) @@ -486,7 +486,7 @@ (and fastfile successp))) (highlight-notes notes) (cond ((and loadp fastfile successp) - (lisp-eval-async `(swank:load-file ,(convert-local-to-remote-file fastfile)) + (lisp-eval-async `(micros:load-file ,(convert-local-to-remote-file fastfile)) (lambda (result) (declare (ignore result)) (uiop:delete-file-if-exists @@ -621,7 +621,7 @@ (save-current-buffer)) (let ((file (buffer-filename (current-buffer)))) (run-hooks (variable-value 'load-file-functions) file) - (lisp-eval-async `(swank:compile-file-for-emacs ,(convert-local-to-remote-file file) t) + (lisp-eval-async `(micros:compile-file-for-emacs ,(convert-local-to-remote-file file) t) #'compilation-finished))) (define-command lisp-compile-region (start end) ("r") @@ -632,7 +632,7 @@ ,(line-number-at-point (current-point)) ,(point-charpos (current-point)))))) (run-hooks (variable-value 'before-compile-functions) start end) - (lisp-eval-async `(swank:compile-string-for-emacs ,string + (lisp-eval-async `(micros:compile-string-for-emacs ,string ,(buffer-name (current-buffer)) ',position ,(buffer-filename (current-buffer)) @@ -681,11 +681,11 @@ (define-command lisp-macroexpand () () (check-connection) - (macroexpand-internal 'swank:swank-macroexpand-1)) + (macroexpand-internal 'micros:swank-macroexpand-1)) (define-command lisp-macroexpand-all () () (check-connection) - (macroexpand-internal 'swank:swank-macroexpand-all)) + (macroexpand-internal 'micros:swank-macroexpand-all)) (define-command lisp-quickload (system-name) ((prompt-for-symbol-name "System: " (buffer-package (current-buffer)))) @@ -699,8 +699,8 @@ (defun make-completions-form-string (string package-name &key (fuzzy t)) (format nil "(~A ~S ~S)" (if fuzzy - "swank:fuzzy-completions" - "swank:completions") + "micros:fuzzy-completions" + "micros:completions") string package-name)) @@ -759,7 +759,7 @@ (prompt-for-symbol-name "Edit Definition of: ")))) (alexandria:when-let (result (find-local-definition point name)) (return-from find-definitions-default result)) - (let ((definitions (lisp-eval `(swank:find-definitions-for-emacs ,name)))) + (let ((definitions (lisp-eval `(micros:find-definitions-for-emacs ,name)))) (definitions-to-locations definitions)))) (defparameter *find-definitions* '(find-definitions-default)) @@ -772,7 +772,7 @@ (check-connection) (let* ((name (or (symbol-string-at-point point) (prompt-for-symbol-name "Edit uses of: "))) - (data (lisp-eval `(swank:xrefs '(:calls :macroexpands :binds + (data (lisp-eval `(micros:xrefs '(:calls :macroexpands :binds :references :sets :specializes) ,name)))) (display-xref-references @@ -840,7 +840,7 @@ (or (symbol-string-at-point (current-point)) "")))) (when (string= "" symbol-name) (editor-error "No symbol given")) - (lisp-eval-describe `(swank:describe-symbol ,symbol-name)))) + (lisp-eval-describe `(micros:describe-symbol ,symbol-name)))) (defvar *wait-message-thread* nil) @@ -1048,10 +1048,10 @@ (defun send-swank-create-server (process port) (lem-process:process-send-input process - "(ql:quickload :swank)") + "(ql:quickload :micros)") (lem-process:process-send-input process - (format nil "(swank:create-server :port ~D :dont-close t)~%" port))) + (format nil "(micros:create-server :port ~D :dont-close t)~%" port))) (defun run-slime (command &key (directory (buffer-directory))) (let* ((port (lem-socket-utils:random-available-port)) diff --git a/modes/lisp-mode/repl.lisp b/modes/lisp-mode/repl.lisp index cde5fbf88..0ac5551de 100644 --- a/modes/lisp-mode/repl.lisp +++ b/modes/lisp-mode/repl.lisp @@ -214,14 +214,14 @@ (start-lisp-repl)))) (defun copy-down-to-repl (slimefun &rest args) - (unless (find-package :swank-repl) - (make-package :swank-repl)) + (unless (find-package :micros/contrib/repl) + (make-package :micros/contrib/repl)) (lisp-eval-async - `(,(read-from-string "swank-repl::listener-save-value") ',slimefun ,@args) + `(,(read-from-string "micros/contrib/repl::listener-save-value") ',slimefun ,@args) (lambda (result) (declare (ignore result)) (lisp-eval-async - `(,(read-from-string "swank-repl::listener-get-value")) + `(,(read-from-string "micros/contrib/repl::listener-get-value")) (lambda (result) (declare (ignore result)) (lem/listener-mode:refresh-prompt (ensure-repl-buffer-exist))))))) @@ -345,7 +345,7 @@ (declare (ignorable n)) (if (self-connection-p *connection*) (message "Can't say sayonara because it's self connection.") - (interactive-eval "(swank:quit-lisp)"))) + (interactive-eval "(micros:quit-lisp)"))) (define-repl-shortcut change-package (n) (declare (ignore n)) diff --git a/modes/lisp-mode/sldb.lisp b/modes/lisp-mode/sldb.lisp index 035e5e7f7..5583b1b27 100644 --- a/modes/lisp-mode/sldb.lisp +++ b/modes/lisp-mode/sldb.lisp @@ -165,7 +165,7 @@ (move-point p (buffer-value (current-buffer) 'backtrace-start-point)) (delete-between-points p (buffer-end-point (current-buffer))) (save-excursion - (sldb-insert-frames p (lisp-eval '(swank:backtrace 0 nil)) nil)))) + (sldb-insert-frames p (lisp-eval '(micros:backtrace 0 nil)) nil)))) (defun sldb-toggle-details (&optional on) (let* ((point (current-point)) @@ -180,7 +180,7 @@ (defun sldb-show-frame-details (point frame-button) (unless (button-get frame-button 'toggle) (destructuring-bind (locals catches) - (lisp-eval `(swank:frame-locals-and-catch-tags + (lisp-eval `(micros:frame-locals-and-catch-tags ,(frame-number (button-get frame-button 'frame)))) (setf (button-get frame-button 'toggle) t) @@ -219,7 +219,7 @@ (insert-string point tag :attribute 'catch-tag-attribute))))))) (defun sldb-inspect-var (frame-number var) - (lisp-eval-async `(swank:inspect-frame-var ,frame-number ,var) + (lisp-eval-async `(micros:inspect-frame-var ,frame-number ,var) 'open-inspector)) (defun sldb-hide-frame-details (point frame-button) @@ -242,7 +242,7 @@ (defun sldb-reinitialize (thread level) (lisp-rex - '(swank:debugger-info-for-emacs 0 10) + '(micros:debugger-info-for-emacs 0 10) :continuation (lambda (value) (alexandria:destructuring-ecase value ((:ok result) @@ -296,7 +296,7 @@ (sldb-toggle-details t)) (define-command sldb-quit () () - (lisp-rex `(swank:throw-to-toplevel) + (lisp-rex `(micros:throw-to-toplevel) :continuation (lambda (value) (alexandria:destructuring-ecase value @@ -306,14 +306,14 @@ (define-command sldb-continue () () (when (null (buffer-value (current-buffer) 'restarts)) (error "continue called outside of debug buffer")) - (lisp-rex '(swank:sldb-continue) + (lisp-rex '(micros:sldb-continue) :continuation (lambda (value) (alexandria:destructuring-case value ((:ok x) (editor-error "sldb-quit returned [~A]" x)))))) (define-command sldb-abort () () - (lisp-eval-async '(swank:sldb-abort) + (lisp-eval-async '(micros:sldb-abort) (lambda (v) (display-message "Restart returned: ~A" v)))) @@ -336,7 +336,7 @@ (define-command sldb-restart-frame (frame-number) ((frame-number-at-point (current-point))) (when frame-number - (lisp-rex `(swank:restart-frame ,frame-number) + (lisp-rex `(micros:restart-frame ,frame-number) :continuation (lambda (v) (alexandria:destructuring-ecase v ((:ok value) (display-message "~A" value)) @@ -344,7 +344,7 @@ (defun sldb-invoke-restart (n) (check-type n integer) - (lisp-rex `(swank:invoke-nth-restart-for-emacs + (lisp-rex `(micros:invoke-nth-restart-for-emacs ,(buffer-value (current-buffer) 'level -1) ,n) :continuation (lambda (x) @@ -379,12 +379,12 @@ (define-command sldb-show-frame-source (frame-number) ((frame-number-at-point (current-point))) - (lisp-eval-async `(swank:frame-source-location ,frame-number) + (lisp-eval-async `(micros:frame-source-location ,frame-number) #'show-source-location)) (defun eval-form-for-frame (format-string) (let* ((frame (frame-number-at-point (current-point))) - (pkg (lisp-eval `(swank:frame-package-name ,frame)))) + (pkg (lisp-eval `(micros:frame-package-name ,frame)))) (list frame (let ((*current-package* pkg)) (prompt-for-sexp (format nil format-string pkg))) @@ -392,42 +392,42 @@ (define-command sldb-eval-in-frame (frame string package) ((:splice (eval-form-for-frame "Eval in frame (~A)> "))) - (lisp-eval-async `(swank:eval-string-in-frame ,string ,frame ,package) + (lisp-eval-async `(micros:eval-string-in-frame ,string ,frame ,package) (lambda (string) (display-message "~A" string)))) (define-command sldb-pprint-eval-in-frame (frame string package) ((:splice (eval-form-for-frame "Eval in frame (~A)> "))) - (lisp-eval-async `(swank:pprint-eval-string-in-frame ,string ,frame ,package) + (lisp-eval-async `(micros:pprint-eval-string-in-frame ,string ,frame ,package) #'write-string-to-repl)) (define-command sldb-inspect-in-frame (string) ((prompt-for-sexp "Inspect in frame (evaluated): ")) (let ((frame-number (frame-number-at-point (current-point)))) - (lisp-eval-async `(swank:inspect-in-frame ,string ,frame-number) + (lisp-eval-async `(micros:inspect-in-frame ,string ,frame-number) 'open-inspector))) (define-command sldb-step () () - (lisp-eval-async `(swank:sldb-step ,(frame-number-at-point (current-point))))) + (lisp-eval-async `(micros:sldb-step ,(frame-number-at-point (current-point))))) (define-command sldb-next () () - (lisp-eval-async `(swank:sldb-step ,(frame-number-at-point (current-point))))) + (lisp-eval-async `(micros:sldb-step ,(frame-number-at-point (current-point))))) (define-command sldb-out () () - (lisp-eval-async `(swank:sldb-out ,(frame-number-at-point (current-point))))) + (lisp-eval-async `(micros:sldb-out ,(frame-number-at-point (current-point))))) (define-command sldb-break-on-return (name) ((prompt-for-symbol-name "Function: ")) - (lisp-eval-async `(swank:sldb-break ,name) + (lisp-eval-async `(micros:sldb-break ,name) (lambda (message) (display-message "~A" message)))) (define-command sldb-inspect-condition () () - (lisp-eval-async '(swank:inspect-current-condition) + (lisp-eval-async '(micros:inspect-current-condition) 'open-inspector)) (define-command sldb-print-condition () () - (lisp-eval-async '(swank:sdlb-print-condition) + (lisp-eval-async '(micros:sdlb-print-condition) (lambda (message) (display-message "~A" message)))) @@ -440,7 +440,7 @@ (lisp-compile-defun))) (define-command sldb-recompile-in-frame-source () () - (lisp-eval-async `(swank:frame-source-location ,(frame-number-at-point (current-point))) + (lisp-eval-async `(micros:frame-source-location ,(frame-number-at-point (current-point))) (lambda (source-location) (alexandria:destructuring-case source-location ((:error message) @@ -450,7 +450,7 @@ (recompile-location source-location)))))) (define-command sldb-copy-down-to-repl () () - (copy-down-to-repl 'swank/backend:frame-var-value + (copy-down-to-repl 'micros/backend:frame-var-value (frame-number-at-point (current-point)) (frame-var-number-at-point (current-point)))) diff --git a/modes/lisp-mode/swank-modules.lisp b/modes/lisp-mode/swank-modules.lisp deleted file mode 100644 index cdd99e29d..000000000 --- a/modes/lisp-mode/swank-modules.lisp +++ /dev/null @@ -1,22 +0,0 @@ -(defpackage :lem-lisp-mode/swank-modules - (:use :cl) - (:export :swank-modules - :require-swank-modules)) -(in-package :lem-lisp-mode/swank-modules) - -(defparameter *swank-modules* - '(:swank-trace-dialog - :swank-package-fu - :swank-presentations - :swank-fuzzy - :swank-fancy-inspector - :swank-c-p-c - :swank-arglists - :swank-repl)) - -(defun swank-modules () - *swank-modules*) - -(defun require-swank-modules (&optional (modules (swank-modules))) - (dolist (module modules) - (require module (swank::module-filename module)))) diff --git a/modes/lisp-mode/swank-protocol.lisp b/modes/lisp-mode/swank-protocol.lisp index ee6977080..7805405b7 100644 --- a/modes/lisp-mode/swank-protocol.lisp +++ b/modes/lisp-mode/swank-protocol.lisp @@ -25,7 +25,6 @@ :finish-evaluated :abort-all :request-connection-info - :request-swank-require :request-listener-eval :read-message :read-all-messages) @@ -42,7 +41,7 @@ (defmacro with-swank-syntax (() &body body) `(with-standard-io-syntax - (let ((*package* (find-package :swank-io-package)) + (let ((*package* (find-package :micros/io-package)) (*print-case* :downcase) (*print-readably* nil)) ,@body))) @@ -186,7 +185,7 @@ Parses length information to determine how many characters to read." (defun setup (connection) (log:debug "Setup connection") - (emacs-rex connection `(swank:connection-info)) + (emacs-rex connection `(micros:connection-info)) ;; Read the connection information message (let* ((info (read-return-message connection)) (data (getf (getf info :return) :ok)) @@ -212,19 +211,14 @@ Parses length information to determine how many characters to read." (connection-prompt-string connection) (getf (getf data :package) :prompt) )) - ;; Require some Swank modules - (request-swank-require - connection - (lem-lisp-mode/swank-modules:swank-modules)) - (read-return-message connection) ;; Start it up (log:debug "Initializing presentations") - (emacs-rex-string connection "(swank:init-presentations)") + (emacs-rex-string connection "(micros:init-presentations)") (read-return-message connection) (log:debug "Creating the REPL") - (emacs-rex-string connection "(swank-repl:create-repl nil :coding-system \"utf-8-unix\")") + (emacs-rex-string connection "(micros/contrib/repl:create-repl nil :coding-system \"utf-8-unix\")") ;; Wait for startup (read-return-message connection) @@ -334,26 +328,12 @@ to check if input is available." :do (funcall fn `(:abort ,condition))) (setf (connection-continuations connection) nil)) -(defun request-swank-require (connection requirements) - "Request that the Swank server load contrib modules. -`requirements` must be a list of symbols, e.g. '(swank-repl swank-media)." - (log:debug "Requesting swank requirements" requirements) - (emacs-rex connection - `(let ((*load-verbose* nil) - (*compile-verbose* nil) - (*load-print* nil) - (*compile-print* nil)) - (handler-bind ((warning #'muffle-warning)) - (swank:swank-require ',(loop for item in requirements collecting - (intern (symbol-name item) - (find-package :swank-io-package)))))))) - (defun request-listener-eval (connection string &optional continuation window-width) "Request that Swank evaluate a string of code in the REPL." (emacs-rex-string connection (if window-width - (format nil "(swank-repl:listener-eval ~S :window-width ~A)" string window-width) - (format nil "(swank-repl:listener-eval ~S)" string)) + (format nil "(micros/contrib/repl:listener-eval ~S :window-width ~A)" string window-width) + (format nil "(micros/contrib/repl:listener-eval ~S)" string)) :continuation continuation :thread ":repl-thread")) diff --git a/modes/scheme-mode/lem-scheme-mode.asd b/modes/scheme-mode/lem-scheme-mode.asd index 7cb329dee..970994763 100644 --- a/modes/scheme-mode/lem-scheme-mode.asd +++ b/modes/scheme-mode/lem-scheme-mode.asd @@ -4,6 +4,7 @@ "usocket" "trivia" "uiop" + "swank" #+#.(cl:if (asdf:find-system :async-process cl:nil) '(and) '(or)) "lem-process" "lem" "lem-socket-utils") diff --git a/third-party/lem-base16-themes b/submodules/lem-base16-themes similarity index 100% rename from third-party/lem-base16-themes rename to submodules/lem-base16-themes diff --git a/submodules/micros b/submodules/micros new file mode 160000 index 000000000..6774243fe --- /dev/null +++ b/submodules/micros @@ -0,0 +1 @@ +Subproject commit 6774243feff95e74d5fcac68ad0058907c1df12d