Commit 10a81172 authored by Dave Cooper's avatar Dave Cooper
Browse files

Merge branch 'feature/glime' into devo

parents a80b37d9 074b48dc
;; $Id: // $
(in-package :swank)
;; glime.lisp
;; Nick Levine, Ravenbrook Limited, 2013-05-02
;; The purpose of this document is to implement GENDL customizations
;; for SLIME (collectively known as "Glime(TM)")
;; The following features have been implemented so far:
;; * modeline and completion help for the keywords accepted by
;; gendl:define-object,
;; * modeline and completion help for the keywords accepted inside an
;; :objects or :hidden-objects argument to gendl:define-object,
;; gendl:make-object, or gendl:make-self.
;; The intended readership is project developers.
;; This document is not confidential. See end for copyright
;; information.
(defparameter *gendl-slime-release* "0.1.1")
;; 2. TESTS
;;; Modified version of swank-arglists.lisp, copied from slime master repo as of Oct 13, 2015.
;; Original credits:
;; Authors: Matthias Koeppe <>
;; Tobias C. Rittweiler <>
;; and others
;; It's handy to be able to test this outside of the SLIME environmemnt.
;; '("define-object" "empty" nil ":objects" ("" %cursor-marker%))
;; ->
;; "(define-object name mixin-list &key ===> objects <=== &allow-other-keys)"
(defun gendl-autodoc-test (raw-form)
(let ((*buffer-package* (find-package "GDL-USER"))
(*buffer-readtable* *readtable*))
(car (autodoc raw-form))))
;; 3. MACROS
;; We need a (very, very) basic and portable advice facility. The
;; potentially dangerous assumption it makes is that the original
;; function won't be redefined behind our backs. I can't think of an
;; easy way to prevent users from doing that. On the other hand,
;; there's no reason why they should.
;; The #+lispworks conditionalisations immediately below are present
;; purely as development aids.
(dspec:define-dspec-alias def-wrap (name)
`(defun ,name))
(defmacro def-wrap (name lambda-list &body body)
"Wrap BODY around the function defined by NAME. Locally defined #'PUNT
will access the original definition."
(let* ((args-var (gensym "ARGS-"))
(cache-form `(unless (get ',name 'gendl-unwrapped)
(setf (get ',name 'gendl-unwrapped) (symbol-function ',name))))
(wrapped-body `(,@(loop for next = (first body)
while (or (stringp next)
(and (consp next)
(eq (car next) 'declare)))
collect (pop body))
(flet ((punt (&rest ,args-var)
(apply (get ',name 'gendl-unwrapped) ,args-var)))
`(dspec:def (def-wrap ,name)
(let ((lw:*redefinition-action* :quiet))
(defun ,name ,lambda-list ,@wrapped-body))
(setf (symbol-function ',name)
(lambda ,lambda-list ,@wrapped-body)))))
(defun wrap-test-original (x)
(cons :original x))
(defun test-def-wrap ()
(def-wrap wrap-test-original (x)
(cons :wrapped (cdr (punt (1+ x)))))
(assert (equal (wrap-test-original 3) '(:wrapped . 4)))
(def-wrap wrap-test-original (x)
(punt x))
(assert (equal (wrap-test-original 3) '(:original . 3))))
;; I keep needing these.
;; License: Public Domain
;; Original GENDL customizations for SLIME: Nick Levine, Ravenbrook Limited, 2013-05-02
(eval-when (:compile-toplevel :load-toplevel :execute)
(swank:swank-require :swank-arglists))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defpackage :gendl-swank
(:use :common-lisp) ;; clean package
;; Internal swank symbols that we use
(:import-from :swank
#:dcase #:match #:with-bindings #:with-struct #:with-buffer-syntax #:without-printing-errors
;; #:arglist -- see below, we don't want to import the structure name.
#:parse-symbol #:valid-function-name-p #:ensure-list #:call/truncated-output-to-string #:from-string
#:type-specifier-arglist #:declaration-arglist
#:find-matching-symbols-in-list #:tokenize-symbol
#:format-completion-set #:completion-output-symbol-converter
#:longest-compound-prefix #:make-compound-prefix-matcher
(in-package :gendl-swank)
(defvar *enable-glime* t "If true, GLIME extensions are enabled. If false, run the unmodified original SWANK versions of everything.")
(defparameter *gendl-slime-release* "0.1.2")
;;;; Utilities
(defparameter +cursor-marker+ 'swank::%cursor-marker%)
;; We don't want to import swank::arglist because then we'd be overwriting the swank::arglist structure.
(defun arglist (fn)
(swank::arglist fn))
(defmacro when-let (binding &body body)
(destructuring-bind (var val) binding
`(let ((,var ,val))
(when ,var
(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))))
(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)
(defmacro multiple-value-or (&rest forms)
(if (null forms)
(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))))))
(defmacro orf (location form &environment env)
(multiple-value-bind (vars values new setter getter)
......@@ -111,29 +114,8 @@
(progn (setf ,current ,form)
(#-clozure glisp:without-redefinition-warnings
#+clozure progn
(defmacro when-let (binding &body body)
(destructuring-bind (var val) binding
`(let ((,var ,val))
(when ,var
(defmacro when-let* (bindings &body body)
(if bindings
`(when-let ,(car bindings)
(when-let* ,(cdr bindings)
`(progn ,@body))))
;; We could do with more informative error handling than SLIME provides. Getting
;; this right can be quite a lot of work, but making a start is cheap.
(defmacro handling-whatever ((&rest options) &body body)
(declare (ignore options))
`(handler-bind ((serious-condition (lambda (condition)
......@@ -142,54 +124,1659 @@
;; The main defintions of the four functions wrapped below are all in
;; the contrib file swank-arglists.lisp.
(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)
(progn ,@body))))
(defmacro defslimefun (name &rest body)
(multiple-value-bind (swank-sym flag) (find-symbol (symbol-name name) :swank)
(assert (eq flag :external))
(defun ,name ,@body)
(redefine-slimefun ',swank-sym ',name))))
(defun redefine-slimefun (swank-sym new-fn)
(multiple-value-bind (sym flag) (find-symbol (symbol-name swank-sym) :swank)
(assert (and (eq sym swank-sym) (eq flag :external))))
(unless (get swank-sym 'gendl-unwrapped)
(setf (get swank-sym 'gendl-unwrapped) (symbol-function swank-sym)))
(setf (symbol-function swank-sym)
(lambda (&rest args)
(declare (dynamic-extent args))
(if *enable-glime*
(apply new-fn args)
(when-let (old-fn (get swank-sym 'gendl-unwrapped))
(apply old-fn args)))))
(defun remove-glime ()
(do-external-symbols (swank-sym :swank)
(when-let (fn (get swank-sym 'gendl-unwrapped))
(setf (symbol-function swank-sym) fn)
(remprop swank-sym 'gendl-unwrapped))))
;;;; 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)))
(defmethod print-object ((dummy arglist-dummy) stream)
(print-unreadable-object (dummy stream :type t :identity nil)
(prin1 (arglist-dummy.string-representation dummy) stream)))
(defun empty-arg-p (dummy)
(and (arglist-dummy-p dummy)
(zerop (length (arglist-dummy.string-representation dummy)))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter +lambda-list-keywords+
'(&provided &required &optional &rest &key &any)))
(defmacro do-decoded-arglist (decoded-arglist &body clauses)
(assert (loop for clause in clauses
thereis (member (car clause) +lambda-list-keywords+)))
(flet ((parse-clauses (clauses)
(let* ((size (length +lambda-list-keywords+))
(initial (make-hash-table :test #'eq :size size))
(main (make-hash-table :test #'eq :size size))
(final (make-hash-table :test #'eq :size size)))
(loop for clause in clauses
for lambda-list-keyword = (first clause)
for clause-parameter = (second clause)
(case clause-parameter
(setf (gethash lambda-list-keyword initial) clause))
(setf (gethash lambda-list-keyword final) clause))
(setf (gethash lambda-list-keyword main) clause)))
(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))))
((&required (&optional arg) . body)
(let ((gensym (gensym "REQUIRED-ARG+")))
`(dolist (,gensym (arglist.required-args ,arglist))
(declare (ignorable ,gensym))
(let (,@(when arg `((,arg ,gensym))))
((&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)))))
((&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)))))
((&rest (&optional arg body-p) . body)
`(when ( ,arglist)
(let (,@(when arg `((,arg ( ,arglist))))
,@(when body-p `((,body-p (arglist.body-p ,arglist)))))
((&any (&optional arg) . body)
(let ((gensym (gensym "REQUIRED-ARG+")))
`(dolist (,gensym (arglist.any-args ,arglist))
(declare (ignorable ,gensym))
(let (,@(when arg `((,arg ,gensym))))
(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)
(print-arg arg :literal-strings t)
(incf index))
(&required (arg)
(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)
(princ '&optional)))
(&optional (arg init-value)
(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)
(princ '&key)))
(&key (keyword arg init)
(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)))
(format t "~:@<(~A ..) ~A~@:>"
(undummy keyword) (undummy init)))
((not (keywordp keyword))
(format t "~:@<(~S ..)~@:>" keyword))
(princ keyword))))))
(&key :finally
(when (arglist.allow-other-keys-p arglist)
(princ '&allow-other-keys)))
(&any :initially
(when (arglist.any-p arglist)
(princ '&any)))
(&any (arg)
(print-arg arg))
(&rest (args bodyp)
(princ (if bodyp '&body '&rest))
(if (arglist-p args)
(print-arglist-recursively args :index index)
(with-highlighting (:index index)
(print-arg args))))
(defun print-arg (arg &key literal-strings)
(let ((arg (if (arglist-dummy-p arg)
(arglist-dummy.string-representation 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)
(prin1 (if (keywordp keyword) keyword `',keyword))
(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))
(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)))
;; The default is to view symbols as if we were in the CL-USER
;; package. I can't see how this helps anybody, so I'm
;; disabling it.
(defvar *arglist-show-packages* nil)
(defmacro with-arglist-io-syntax (&body body)
(let ((package (gensym)))
`(let ((,package *package*))
(let ((*package* (if *arglist-show-packages*
(with-bindings *arglist-pprint-bindings*
(defun decoded-arglist-to-string (decoded-arglist
&key operator highlight
(if (message-list-arglist-p operator decoded-arglist)
(print-message-list-for-autodoc decoded-arglist print-right-margin)
(with-output-to-string (*standard-output*)
(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*)
(print-decoded-arglist-as-template decoded-arglist
:prefix prefix
:suffix suffix))))