[slime-cvs] CVS slime/contrib
trittweiler
trittweiler at common-lisp.net
Wed Sep 5 18:48:49 UTC 2007
Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv26346/contrib
Modified Files:
swank-arglists.lisp
Log Message:
Added extended arglist display for DECLAIM and PROCLAIM.
* slime.el (slime-extended-operator-name-parser-alist): Added
entries for "DECLAIM", and "PROCLAIM".
(slime-parse-extended-operator/declare): Provide information about
the operator the arglist is requested for.
(slime-make-form-spec-from-string): Fixed for "()" as input.
* swank-arglists.lisp (valid-operator-symbol-p): Explicitly allow
the symbol 'DECLARE.
(arglist-dispatch): New method for `DECLARE'. We have to catch
this explicitly, as DECLARE doesn't have an arglist (in the
`swank-backend:arglist' sense.)
(*arglist-pprint-bindings*): New variable. Splitted out from
`decoded-arglist-to-string'.
(decoded-arglist-to-string): Use `*arglist-pprint-bindings*'.
(parse-first-valid-form-spec): Rewritten, because function
signature had to be changed: doesn't take arg-indices anymore;
returns position of first valid spec as second value to remedy.
(arglist-for-echo-area): Accomodated to new signature of
`parse-first-valid-form-spec'; now searchs for contextual
declaration operator name, to prefix a declaration arglist by
"declare", "declaim", or "proclaim" depending on what was used at
user's point in Slime. Use `*arglist-pprint-bindings*' for
printing the found declaration operator name.
(%find-declaration-operator): New helper to do this search.
(completions-for-keyword): Accomodated to new signature of
`parse-first-valid-form-spec'. Also fixed to correctly provide
keyword completions in nested expressions like:
`(defun foo (x)
(let ((bar 'quux))
(with-open-file (s f :|' [`|' being point]
--- /project/slime/cvsroot/slime/contrib/swank-arglists.lisp 2007/09/04 15:45:20 1.7
+++ /project/slime/cvsroot/slime/contrib/swank-arglists.lisp 2007/09/05 18:48:49 1.8
@@ -16,7 +16,8 @@
"Is SYMBOL the name of a function, a macro, or a special-operator?"
(or (fboundp symbol)
(macro-function symbol)
- (special-operator-p symbol)))
+ (special-operator-p symbol)
+ (eq symbol 'declare)))
(defun valid-operator-name-p (string)
"Is STRING the name of a function, macro, or special-operator?"
@@ -33,9 +34,8 @@
``form specs'', please see PARSE-FORM-SPEC."
(handler-case
(with-buffer-syntax ()
- (multiple-value-bind (form-spec arg-index newly-interned-symbols)
- (parse-first-valid-form-spec raw-specs arg-indices
- #'read-conversatively-for-autodoc)
+ (multiple-value-bind (form-spec position newly-interned-symbols)
+ (parse-first-valid-form-spec raw-specs #'read-conversatively-for-autodoc)
(unwind-protect
(when form-spec
(let ((arglist (arglist-from-form-spec form-spec :remove-args nil)))
@@ -49,19 +49,28 @@
: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))
+ :highlight (let ((index (nth position arg-indices)))
+ ;; don't highlight the operator
+ (and index (not (zerop index)) index)))
+ ;; Post formatting:
(case type
- (:declaration (format nil "(declare ~A)" stringified-arglist))
(:type-specifier (format nil "[Typespec] ~A" stringified-arglist))
+ (:declaration
+ (with-bindings *arglist-pprint-bindings*
+ (let ((op (%find-declaration-operator raw-specs position)))
+ (if op
+ (format nil "(~A ~A)" op stringified-arglist)
+ (format nil "[Declaration] ~A" stringified-arglist)))))
(t stringified-arglist)))))))
(mapc #'unintern-in-home-package newly-interned-symbols))))
(error (cond)
(format nil "ARGLIST (error): ~A" cond))
))
+(defun %find-declaration-operator (raw-specs position)
+ (let ((op-rawspec (nth (1+ position) raw-specs)))
+ (first (parse-form-spec op-rawspec #'read-conversatively-for-autodoc))))
+
(defvar *arglist-dummy* (cons :dummy nil))
(defun read-conversatively-for-autodoc (string)
@@ -132,9 +141,9 @@
(flet ((parse-extended-spec (raw-extension extension-flag)
(when (and (stringp (first raw-extension)) ; (:DECLARATION (("a" "b" ("c")) "d"))
(nth-value 1 (parse-symbol (first raw-extension))))
- (multiple-value-bind (extension introduced-symbols)
+ (multiple-value-bind (extension introduced-symbols)
(read-form-spec raw-extension reader)
- (unless (recursively-empty-p extension) ; (:DECLARATION (())) &c.
+ (unless (recursively-empty-p extension) ; (:DECLARATION (())) &c.
(destructuring-bind (identifier &rest args) extension
(values `((,extension-flag ,identifier) , at args)
introduced-symbols)))))))
@@ -164,17 +173,15 @@
(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 reader)
+(defun parse-first-valid-form-spec (raw-specs &optional reader)
"Returns the first parsed form spec in RAW-SPECS that can
-successfully be parsed. Additionally returns its respective index
-in ARG-INDICES (or NIL.), and all newly interned symbols as tertiary
-return value."
- (do ((raw raw-specs (cdr raw))
- (arg arg-indices (cdr arg)))
- ((null raw) nil)
- (let ((raw-spec (car raw)) (index (car arg)))
- (multiple-value-bind (spec symbols) (parse-form-spec raw-spec reader)
- (when spec (return (values spec index symbols)))))))
+successfully be parsed. Additionally returns that spec's position
+as secondary, and all newly interned symbols as tertiary return
+value."
+ (loop for raw-spec in raw-specs
+ for pos upfrom 0
+ do (multiple-value-bind (spec symbols) (parse-form-spec raw-spec reader)
+ (when spec (return (values spec pos symbols))))))
(defun read-form-spec (spec &optional reader)
"Turns the ``raw form spec'' SPEC into a proper Common Lisp
@@ -370,6 +377,15 @@
(mapc #'print-with-space
(arglist.unknown-junk arglist))))))
+(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))) ; no package qualifiers.
+
(defun decoded-arglist-to-string (arglist
&key operator highlight (package *package*)
print-right-margin print-lines)
@@ -380,13 +396,11 @@
If OPERATOR is non-nil, put it in front of the arglist."
(with-output-to-string (*standard-output*)
(with-standard-io-syntax
- (let ((*package* package) (*print-case* :downcase)
- (*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-escape* nil)) ; no package qualifies.
- (print-arglist arglist :operator operator :highlight highlight)))))
+ (with-bindings *arglist-pprint-bindings*
+ (let ((*package* package)
+ (*print-right-margin* print-right-margin)
+ (*print-lines* print-lines))
+ (print-arglist arglist :operator operator :highlight highlight))))))
(defslimefun variable-desc-for-echo-area (variable-name)
"Return a short description of VARIABLE-NAME, or NIL."
@@ -1052,10 +1066,16 @@
(defmethod arglist-dispatch ((operator-type (eql :function)) (operator (eql 'eval-when))
arguments &key (remove-args t))
(let ((eval-when-args '(:compile-toplevel :load-toplevel :execute)))
- (maybecall remove-args #'remove-actual-args
- (make-arglist :required-args (list (make-arglist :any-args eval-when-args))
- :rest '#:body :body-p t)
- arguments)))
+ (make-arglist :required-args (list (maybecall remove-args #'remove-actual-args
+ (make-arglist :any-args eval-when-args)
+ arguments))
+ :rest '#:body :body-p t)))
+
+(defmethod arglist-dispatch ((operator-type (eql :function)) (operator (eql 'declare))
+ arguments &key (remove-args t))
+ ;; Catching 'DECLARE before SWANK-BACKEND:ARGLIST can barf.
+ (declare (ignore remove-args))
+ (make-arglist :rest '#:decl-specifiers))
(defmethod arglist-dispatch ((operator-type (eql :declaration))
decl-identifier decl-args &key (remove-args t))
@@ -1125,39 +1145,38 @@
(let ((arg (elt args index)))
(apply #'arglist-ref arg nil (rest indices))))))))
-(defslimefun completions-for-keyword (raw-specs keyword-string arg-indices)
+(defslimefun completions-for-keyword (raw-specs keyword-string arg-index-specs)
(with-buffer-syntax ()
- (multiple-value-bind (form-spec index newly-interned-symbols)
- (parse-first-valid-form-spec raw-specs arg-indices)
+ (multiple-value-bind (form-spec position newly-interned-symbols)
+ (parse-first-valid-form-spec raw-specs)
(unwind-protect
(when form-spec
- (let ((arglist (arglist-from-form-spec form-spec :remove-args nil)))
+ (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 type arguments))
- (let* ((indices (butlast (reverse (last arg-indices (1+ index)))))
- (arglist (apply #'arglist-ref arglist operator indices)))
- (when (and arglist (arglist-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
- #'compound-prefix-match))
- (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)))))))))
+ (let* ((operator (nth-value 1 (split-form-spec form-spec)))
+ (indices (reverse (rest (subseq arg-index-specs 0 (1+ position)))))
+ (arglist (apply #'arglist-ref arglist operator indices)))
+ (when (and arglist (arglist-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
+ #'compound-prefix-match))
+ (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))))))))
(mapc #'unintern-in-home-package newly-interned-symbols)))))
More information about the slime-cvs
mailing list