[slime-cvs] CVS slime
trittweiler
trittweiler at common-lisp.net
Thu Aug 23 16:19:56 UTC 2007
Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv5660
Modified Files:
swank.lisp
Log Message:
Added arglist display for declaration specifiers and type
specifiers.
Examples:
`(declare (type' will display
(declare (type type-specifier &rest vars))
`(declare (type (float' will display
[Typespec] (float &optional lower-limit upper-limit)
`(declare (optimize' will display
(declare (optimize &any (safety 1) (space 1) (speed 1) ...))
&ANY is a new lambda keyword that is introduced for arglist
description purpose, and is very similiar to &KEY, but isn't based
upon plists; they're more based upon *FEATURES* lists. (See the
comment near the ARGLIST defstruct in `swank.lisp'.)
* slime.el:
(slime-to-feature-keyword): Renamed to `slime-keywordify'.
(slime-eval-feature-conditional): Adapted to use `slime-keywordify'.
(slime-ensure-list): New utility.
(slime-sexp-at-point): Now takes an argument that specify how many
sexps at point should be returned.
(slime-enclosing-operator-names): Renamed to
`slime-enclosing-form-specs'.
(slime-enclosing-form-specs): Returns a list of ``raw form specs''
instead of what was called ``extended operator names'' before, see
`swank::parse-form-spec' for more information. This is a
simplified superset. Additionally as tertiary return value return
a list of points to let the caller see where each form spec is
located. Adapted callers accordingly. Extended docstring.
(slime-parse-extended-operator-name): Adapted to changes in
`slime-enclosing-form-specs'. Now gets more context, and is such
more powerful. This was needed to allow parsing DECLARE forms.
(slime-make-extended-operator-parser/look-ahead): Because the
protocol for arglist display was simplified, it was possible to
replace the plethora of parsing function just by this one.
(slime-extended-operator-name-parser-alist): Use it. Also add
parser for DECLARE forms.
(slime-parse-extended-operator/declare): Responsible for parsing
DECLARE forms.
(%slime-in-mid-of-typespec-p): Helper function for
`slime-parse-extended-operator/declare'.
(slime-incomplete-form-at-point): New. Return the ``raw form
spec'' near point.
(slime-complete-form): Use `slime-incomplete-form-at-point'.
* swank.lisp: New Helper functions.
(length=, ensure-list, recursively-empty-p): New.
(maybecall, exactly-one-p): New.
* swank.lisp (arglist-for-echo-area): Adapted to take ``raw form
specs'' from Slime.
(parse-form-spec): New. Takes a ``raw form spec'' and returns a
``form spec'' for further processing in Swank. Docstring documents
these two terms.
(split-form-spec): New. Return relevant information from a form spec.
(parse-first-valid-form-spec): Replaces `find-valid-operator-name'.
(find-valid-operator-name): Removed.
(operator-designator-to-form): Removed. Obsoleted by `parse-form-spec'.
(defstruct arglist): Add `any-p' and `any-args' slots to contain
arguments belonging to the &ANY lambda keyword.
(print-arglist): Adapted to also print &ANY args.
(print-decoded-arglist-as-template): Likewise.
(decode-arglist): Adapted to also decode &ANY args.
(remove-actual-args): Adapted to also remove &ANY args.
(remove-&key-args): Split out from `remove-actual-args'.
(remove-&any-args): New. Removes already provided &ANY args.
(arglist-from-form-spec): New. Added detailed docstring.
(arglist-dispatch): Dispatching generic function for
`arglist-from-form-spec' that does all the work. Renamed from
prior `form-completion'.
(arglist-dispatch) Added methods for dealing with declaration and
type-specifiers.
(complete-form): Adapted to take ``raw form specs'' from Slime.
(completions-for-keyword): Likewise.
(format-arglist-for-echo-area): Removed. Not needed anymore.
* swank-backend.lisp (declaration-arglist): New generic
function. Returns the arglist for a given declaration
identifier. (Backends are supposed to specialize it if they can
provide additional information.)
(type-specifier-arglist): New generic function. Returns the
arglist for a given type-specifier operator. (Backends are
supposed to specialize it if they can provide additional
information.)
(*type-specifier-arglists*): New variable. Contains the arglists
for the type specifiers in Common Lisp.
* swank-sbcl.lisp: Now depends upon sb-cltl2.
(declaration-arglist 'optimize): Specialize the `optimize'
declaration identifier to pass it to
sb-cltl2:declaration-information.
--- /project/slime/cvsroot/slime/swank.lisp 2007/08/23 13:56:22 1.493
+++ /project/slime/cvsroot/slime/swank.lisp 2007/08/23 16:19:56 1.494
@@ -390,6 +390,40 @@
(defun ascii-char-p (c)
(<= (char-code c) 127))
+(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))))
+
+(defun ensure-list (thing)
+ (if (listp thing) thing (list thing)))
+
+(defun recursively-empty-p (list)
+ "Returns whether LIST consists only of arbitrarily nested empty lists."
+ (cond ((not (listp list)) nil)
+ ((null list) t)
+ (t (every #'recursively-empty-p list))))
+
+(defun maybecall (bool fn &rest args)
+ "Call FN with ARGS if BOOL is T. Otherwise return ARGS as multiple values."
+ (if bool (apply fn args) (values-list args)))
+
+(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))
+
(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")))
@@ -1513,54 +1547,124 @@
;;;; Arglists
-(defun find-valid-operator-name (names)
- "As a secondary result, returns its index."
- (let ((index
- (position-if (lambda (name)
- (or (consp name)
- (valid-operator-name-p name)))
- names)))
- (if index
- (values (elt names index) index)
- (values nil nil))))
-
-(defslimefun arglist-for-echo-area (names &key print-right-margin
- print-lines arg-indices)
- "Return the arglist for the first function, macro, or special-op in NAMES."
- (handler-case
+(defslimefun arglist-for-echo-area (raw-specs &key arg-indices
+ print-right-margin print-lines)
+ "Return the arglist for the first valid ``form spec'' in
+RAW-SPECS. A ``form spec'' is a superset of functions, macros,
+special-ops, declarations and type specifiers.
+
+For more information about the format of ``raw form specs'' and
+``form specs'', please see PARSE-FORM-SPEC."
+ (handler-case
(with-buffer-syntax ()
- (multiple-value-bind (name which)
- (find-valid-operator-name names)
- (when which
- (let ((arg-index (and arg-indices (elt arg-indices which))))
- (multiple-value-bind (form operator-name)
- (operator-designator-to-form name)
- (let ((*print-right-margin* print-right-margin))
- (format-arglist-for-echo-area
- form operator-name
- :print-right-margin print-right-margin
- :print-lines print-lines
- :highlight (and arg-index
- (not (zerop arg-index))
- ;; don't highlight the operator
- arg-index))))))))
+ (multiple-value-bind (form-spec arg-index)
+ (parse-first-valid-form-spec raw-specs arg-indices)
+ (when form-spec
+ (let ((arglist (arglist-from-form-spec form-spec :remove-args nil)))
+ (unless (eql arglist :not-available)
+ (multiple-value-bind (type operator arguments)
+ (split-form-spec form-spec)
+ (declare (ignore arguments))
+ (multiple-value-bind (stringified-arglist)
+ (decoded-arglist-to-string
+ arglist
+ :operator operator
+ :print-right-margin print-right-margin
+ :print-lines print-lines
+ :highlight (and arg-index
+ (not (zerop arg-index))
+ ;; don't highlight the operator
+ arg-index))
+ (case type
+ (:declaration (format nil "(declare ~A)" stringified-arglist))
+ (:type-specifier (format nil "[Typespec] ~A" stringified-arglist))
+ (t stringified-arglist)))))))))
(error (cond)
- (format nil "ARGLIST: ~A" cond))))
+ (format nil "ARGLIST (error): ~A" cond))
+ ))
+
+(defun parse-form-spec (raw-spec)
+ "Takes a raw (i.e. unparsed) form spec from SLIME and returns a
+proper form spec for further processing within SWANK. Returns NIL
+if RAW-SPEC could not be parsed.
+
+A ``raw form spec'' can be either:
+
+ i) a string representing a Common Lisp symbol,
+
+ ii) a string representing a Common Lisp form,
+
+ iii) a list:
+
+ a) (:declaration declspec)
+
+ where DECLSPEC is the string representation of a /declaration specifier/,
+
+ b) (:type-specifier typespec)
+
+ where TYPESPEC is the string representation of a /type specifier/.
+
+
+A ``form spec'' is either
+
+ 1) a normal Common Lisp form
+
+ 2) a Common Lisp form with a list as its CAR specifying what namespace
+ the operator is supposed to be interpreted in:
+
+ a) ((:declaration decl-identifier) declarg1 declarg2 ...)
+
+ b) ((:type-specifier typespec-op) typespec-arg1 typespec-arg2 ...)
+
+
+Examples:
+
+ \"defmethod\" => (defmethod)
+ \"cl:defmethod\" => (cl:defmethod)
+ \"(defmethod print-object)\" => (defmethod print-object)
+ (:declaration \"(optimize)\") => ((:declaration optimize))
+ (:declaration \"(type string)\") => ((:declaration type) string)
+ (:type-specifier \"(float)\") => ((:type-specifier float))
+ (:type-specifier \"(float 0 100)\") => ((:type-specifier float) 0 100)
+"
+ (typecase raw-spec
+ (string (ensure-list (read-incomplete-form-from-string raw-spec)))
+ (cons ; compound form spec
+ (destructure-case raw-spec
+ ((:declaration raw-declspec)
+ (let ((declspec (from-string raw-declspec)))
+ (unless (recursively-empty-p declspec) ; (:DECLARATION "(())") &c.
+ (destructuring-bind (decl-identifier &rest decl-args) declspec
+ `((:declaration ,decl-identifier) , at decl-args)))))
+ ((:type-specifier raw-typespec)
+ (let ((typespec (from-string raw-typespec)))
+ (unless (recursively-empty-p typespec)
+ (destructuring-bind (typespec-op &rest typespec-args) typespec
+ `((:type-specifier ,typespec-op) , at typespec-args)))))))
+ (otherwise nil)))
+
+(defun split-form-spec (spec)
+ "Returns all three relevant information a ``form spec''
+contains: the operator type, the operator, and the operands."
+ (destructuring-bind (operator-designator &rest arguments) spec
+ (multiple-value-bind (type operator)
+ (if (listp operator-designator)
+ (values (first operator-designator) (second operator-designator))
+ (values :function operator-designator)) ; functions, macros, special ops
+ (values type operator arguments)))) ; are all fbound.
+
+(defun parse-first-valid-form-spec (raw-specs &optional arg-indices)
+ "Returns the first parsed form spec in RAW-SPECS that can
+successfully be parsed. Additionally returns its respective index
+in ARG-INDICES (or NIL.)"
+ (block traversal
+ (mapc #'(lambda (raw-spec index)
+ (let ((spec (parse-form-spec raw-spec)))
+ (when spec (return-from traversal
+ (values spec index)))))
+ raw-specs
+ (append arg-indices '#1=(nil . #1#)))))
-(defun operator-designator-to-form (name)
- (etypecase name
- (cons
- (destructure-case name
- ((:make-instance class-name operator-name &rest args)
- (let ((parsed-operator-name (parse-symbol operator-name)))
- (values `(,parsed-operator-name , at args ',(parse-symbol class-name))
- operator-name)))
- ((:defmethod generic-name)
- (values `(defmethod ,(parse-symbol generic-name))
- 'defmethod))))
- (string
- (values `(,(parse-symbol name))
- name))))
(defun clean-arglist (arglist)
"Remove &whole, &enviroment, and &aux elements from ARGLIST."
@@ -1571,6 +1675,7 @@
'())
(t (cons (car arglist) (clean-arglist (cdr arglist))))))
+
(defstruct (arglist (:conc-name arglist.) (:predicate arglist-p))
provided-args ; list of the provided actual arguments
required-args ; list of the required arguments
@@ -1581,9 +1686,43 @@
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) ...))
+;;;
+
(defun print-arglist (arglist &key operator highlight)
(let ((index 0)
(need-space nil))
@@ -1654,6 +1793,10 @@
(arglist.keyword-args arglist)))
(when (arglist.allow-other-keys-p arglist)
(print-with-space '&allow-other-keys))
+ (when (arglist.any-args arglist)
+ (print-with-space '&any)
+ (mapc #'print-with-space
+ (arglist.any-args arglist)))
(cond ((not (arglist.rest arglist)))
((arglist.body-p arglist)
(print-with-space '&body)
@@ -1664,9 +1807,9 @@
(mapc #'print-with-space
(arglist.unknown-junk arglist))))))
-(defun decoded-arglist-to-string (arglist package
- &key operator print-right-margin
- print-lines highlight)
+(defun decoded-arglist-to-string (arglist
+ &key operator highlight (package *package*)
+ print-right-margin print-lines)
"Print the decoded ARGLIST for display in the echo area. The
argument name are printed without package qualifiers and pretty
printing of (function foo) as #'foo is suppressed. If HIGHLIGHT is
@@ -1678,7 +1821,8 @@
(*print-pretty* t) (*print-circle* nil) (*print-readably* nil)
(*print-level* 10) (*print-length* 20)
(*print-right-margin* print-right-margin)
- (*print-lines* print-lines))
+ (*print-lines* print-lines)
+ (*print-escape* nil)) ; no package qualifies.
(print-arglist arglist :operator operator :highlight highlight)))))
(defslimefun variable-desc-for-echo-area (variable-name)
@@ -1813,6 +1957,10 @@
((member 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))
((member arg lambda-list-keywords)
(setq mode '&unknown-junk)
(push arg (arglist.unknown-junk result)))
@@ -1837,13 +1985,18 @@
(arglist.required-args result)))
((&whole &environment)
(setf mode nil)
- (push arg (arglist.known-junk result)))))))
+ (push arg (arglist.known-junk result)))
+ (&any
+ (push arg (arglist.any-args result)))))))
(nreversef (arglist.required-args result))
(nreversef (arglist.optional-args result))
(nreversef (arglist.keyword-args result))
(nreversef (arglist.aux-args result))
+ (nreversef (arglist.any-args result))
(nreversef (arglist.known-junk result))
(nreversef (arglist.unknown-junk result))
+ (assert (or (and (not (arglist.key-p result)) (not (arglist.any-p result)))
+ (exactly-one-p (arglist.key-p result) (arglist.any-p result))))
result))
(defun encode-arglist (decoded-arglist)
@@ -1856,6 +2009,8 @@
(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)
@@ -1946,6 +2101,9 @@
(format t "~W "
(if (keywordp keyword) keyword `',keyword))
(print-arg-or-pattern arg-name)))
+ (dolist (any-arg (arglist.any-args decoded-arglist))
+ (space)
+ (print-arg-or-pattern any-arg))
(when (and (arglist.rest decoded-arglist)
(or (not (arglist.keyword-args decoded-arglist))
(arglist.allow-other-keys-p decoded-arglist)))
@@ -1955,6 +2113,7 @@
(format t "~A..." (arglist.rest decoded-arglist)))))
(pprint-newline :fill)))
+
(defgeneric extra-keywords (operator &rest args)
(:documentation "Return a list of extra keywords of OPERATOR (a
symbol) when applied to the (unevaluated) ARGS.
@@ -1962,6 +2121,18 @@
As a tertiary value, return the initial sublist of ARGS that was needed
to determine the extra keywords."))
+(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."
+ (let ((arglist (arglist-from-form-spec (ensure-list operator)
+ :remove-args nil)))
+ (unless (eql arglist :not-available)
+ (values
+ (arglist.keyword-args arglist)
+ (arglist.allow-other-keys-p arglist)))))
+
(defmethod extra-keywords (operator &rest args)
;; default method
(declare (ignore args))
@@ -2164,7 +2335,7 @@
argument-forms)
(let ((function-name-form (car argument-forms)))
(when (and (listp function-name-form)
- (= (length function-name-form) 2)
+ (length= function-name-form 2)
(member (car function-name-form) '(quote function)))
(let ((function-name (cadr function-name-form)))
(when (valid-operator-symbol-p function-name)
@@ -2214,6 +2385,10 @@
(defun remove-actual-args (decoded-arglist actual-arglist)
"Remove from DECODED-ARGLIST the arguments that have already been
provided in ACTUAL-ARGLIST."
+ (assert (or (and (not (arglist.key-p decoded-arglist))
+ (not (arglist.any-p decoded-arglist)))
+ (exactly-one-p (arglist.key-p decoded-arglist)
+ (arglist.any-p decoded-arglist))))
(loop while (and actual-arglist
(arglist.required-args decoded-arglist))
do (progn (pop actual-arglist)
@@ -2222,22 +2397,71 @@
(arglist.optional-args decoded-arglist))
do (progn (pop actual-arglist)
(pop (arglist.optional-args decoded-arglist))))
[307 lines skipped]
More information about the slime-cvs
mailing list