[slime-cvs] CVS slime/contrib
CVS User trittweiler
trittweiler at common-lisp.net
Sat Oct 31 22:13:55 UTC 2009
Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv6057/contrib
Modified Files:
ChangeLog slime-autodoc.el slime-c-p-c.el
slime-highlight-edits.el slime-parse.el swank-arglists.lisp
Log Message:
* slime.el (slime-inside-string-p, slime-inside-comment-p)
(slime-inside-string-or-comment-p): New.
* swank-match.lisp: New file. Contains very simple pattern matcher
from the CMU AI archive.
* swank-loader.lisp: Compile swank-match.lisp.
* swank.lisp: Make SWANK package use new SWANK-MATCH package.
* slime-autodoc.el, swank-arglists.lisp: Large parts were
rewritten. Autodoc is now able to highlight &key parameters, and
parameters in nested arglists.
* slime-parse.el, slime-c-p-c.el, slime-highlighting-edits.el:
Adapted to changes.
--- /project/slime/cvsroot/slime/contrib/ChangeLog 2009/10/31 21:31:49 1.265
+++ /project/slime/cvsroot/slime/contrib/ChangeLog 2009/10/31 22:13:55 1.266
@@ -1,5 +1,14 @@
2009-10-31 Tobias C. Rittweiler <tcr at freebits.de>
+ * slime-autodoc.el, swank-arglists.lisp: Large parts were
+ rewritten. Autodoc is now able to highlight &key parameters, and
+ parameters in nested arglists.
+
+ * slime-parse.el, slime-c-p-c.el, slime-highlighting-edits.el:
+ Adapted to changes.
+
+2009-10-31 Tobias C. Rittweiler <tcr at freebits.de>
+
* slime-autodoc.el (slime-autodoc-worthwile-p): New helper.
(slime-compute-autodoc-internal): Use it to only perform an RPC
request if it's worthwhile to do so. For example, don't do it if
--- /project/slime/cvsroot/slime/contrib/slime-autodoc.el 2009/10/31 21:31:49 1.21
+++ /project/slime/cvsroot/slime/contrib/slime-autodoc.el 2009/10/31 22:13:55 1.22
@@ -31,7 +31,7 @@
:type 'boolean
:group 'slime-ui)
-(defcustom slime-autodoc-delay 0.2
+(defcustom slime-autodoc-delay 0.3
"*Delay before autodoc messages are fetched and displayed, in seconds."
:type 'number
:group 'slime-ui)
@@ -53,16 +53,23 @@
"Not used; for debugging purposes."
(multiple-value-bind (operators arg-indices points)
(slime-enclosing-form-specs)
- (slime-compute-autodoc-rpc-form operators arg-indices points)))
+ (slime-make-autodoc-rpc-form operators arg-indices points)))
-(defun slime-compute-autodoc-rpc-form (operators arg-indices points)
+;; TODO: get rid of args
+(defun slime-make-autodoc-rpc-form (operators arg-indices points)
"Return a cache key and a swank form."
- (let ((global (slime-autodoc-global-at-point)))
- (if global
- (values (slime-qualify-cl-symbol-name global)
- `(swank:variable-desc-for-echo-area ,global))
- (values (slime-make-autodoc-cache-key operators arg-indices points)
- (slime-make-autodoc-swank-form operators arg-indices points)))))
+ (unless (slime-inside-string-or-comment-p)
+ (let ((global (slime-autodoc-global-at-point)))
+ (if global
+ (values (slime-qualify-cl-symbol-name global)
+ `(swank:variable-desc-for-echo-area ,global))
+ (let ((buffer-form (slime-parse-form-upto-point 10)))
+ (values buffer-form
+ (multiple-value-bind (width height)
+ (slime-autodoc-message-dimensions)
+ `(swank:arglist-for-echo-area ',buffer-form
+ :print-right-margin ,width
+ :print-lines ,height))))))))
(defun slime-autodoc-global-at-point ()
"Return the global variable name at point, if any."
@@ -82,37 +89,6 @@
(and (< (length name) 80) ; avoid overflows in regexp matcher
(string-match slime-global-variable-name-regexp name)))
-(defun slime-make-autodoc-cache-key (ops indices points)
- (mapcar* (lambda (designator arg-index)
- (let ((designator (if (symbolp designator)
- (slime-qualify-cl-symbol-name designator)
- designator)))
- `(,designator . ,arg-index)))
- operators arg-indices))
-
-(defun slime-make-autodoc-swank-form (ops indices points)
- (multiple-value-bind (width height)
- (slime-autodoc-message-dimensions)
- (let ((local-arglist (slime-autodoc-local-arglist ops indices points)))
- (if local-arglist
- `(swank:format-arglist-for-echo-area ,local-arglist
- :operator ,(first (first ops))
- :highlight ,(if (zerop (first indices)) nil (first indices))
- :print-right-margin ,width
- :print-lines ,height)
- `(swank:arglist-for-echo-area ',ops
- :arg-indices ',indices
- :print-right-margin ,width
- :print-lines ,height)))))
-
-(defun slime-autodoc-local-arglist (ops indices points)
- (let* ((cur-op (first ops))
- (cur-op-name (first cur-op)))
- (multiple-value-bind (bound-fn-names arglists)
- (slime-find-bound-functions ops indices points)
- (when-let (pos (position cur-op-name bound-fn-names :test 'equal))
- (nth pos arglists)))))
-
(defvar slime-autodoc-dimensions-function nil)
(defun slime-autodoc-message-dimensions ()
@@ -221,7 +197,7 @@
(when (slime-autodoc-worthwhile-p ops)
(run-hook-with-args 'slime-autodoc-hook ops arg-indices points)
(multiple-value-bind (cache-key retrieve-form)
- (slime-compute-autodoc-rpc-form ops arg-indices points)
+ (slime-make-autodoc-rpc-form ops arg-indices points)
(let ((cached (slime-get-cached-autodoc cache-key)))
(if cached
cached
@@ -231,7 +207,10 @@
(slime-eval-async retrieve-form
(lexical-let ((cache-key cache-key))
(lambda (doc)
- (let ((doc (if doc (slime-format-autodoc doc) "")))
+ (let ((doc (if (or (null doc)
+ (eq doc :not-available))
+ ""
+ (slime-format-autodoc doc))))
;; Now that we've got our information, get it to
;; the user ASAP.
(eldoc-message doc)
--- /project/slime/cvsroot/slime/contrib/slime-c-p-c.el 2009/10/31 20:18:28 1.13
+++ /project/slime/cvsroot/slime/contrib/slime-c-p-c.el 2009/10/31 22:13:55 1.14
@@ -112,21 +112,18 @@
(let ((token (buffer-substring-no-properties beg end)))
(cond
((and (< beg (point-max))
- (string= (buffer-substring-no-properties beg (1+ beg)) ":"))
+ (string= (buffer-substring-no-properties beg (1+ beg)) ":"))
;; Contextual keyword completion
- (multiple-value-bind (operator-names arg-indices points)
- (save-excursion
- (goto-char beg)
- (slime-enclosing-form-specs))
- (when operator-names
- (let ((completions
- (slime-completions-for-keyword operator-names token
- arg-indices)))
- (when (first completions)
- (return-from slime-contextual-completions completions))
- ;; If no matching keyword was found, do regular symbol
- ;; completion.
- ))))
+ (let ((completions
+ (slime-completions-for-keyword token
+ (save-excursion
+ (goto-char beg)
+ (slime-parse-form-upto-point)))))
+ (when (first completions)
+ (return-from slime-contextual-completions completions))
+ ;; If no matching keyword was found, do regular symbol
+ ;; completion.
+ ))
((and (>= (length token) 2)
(string= (subseq token 0 2) "#\\"))
;; Character name completion
@@ -138,11 +135,8 @@
(defun slime-completions (prefix)
(slime-eval `(swank:completions ,prefix ',(slime-current-package))))
-(defun slime-completions-for-keyword (operator-designator prefix
- arg-indices)
- (slime-eval `(swank:completions-for-keyword ',operator-designator
- ,prefix
- ',arg-indices)))
+(defun slime-completions-for-keyword (prefix buffer-form)
+ (slime-eval `(swank:completions-for-keyword ,prefix ',buffer-form)))
(defun slime-completions-for-character (prefix)
(flet ((append-char-syntax (string) (concat "#\\" string)))
@@ -160,17 +154,14 @@
This is a superset of the functionality of `slime-insert-arglist'."
(interactive)
;; Find the (possibly incomplete) form around point.
- (let ((form-string (slime-incomplete-form-at-point)))
- (let ((result (slime-eval `(swank:complete-form ',form-string))))
+ (let ((buffer-form (slime-parse-form-upto-point)))
+ (let ((result (slime-eval `(swank:complete-form ',buffer-form))))
(if (eq result :not-available)
- (error "Could not generate completion for the form `%s'" form-string)
+ (error "Could not generate completion for the form `%s'" buffer-form)
(progn
- (just-one-space)
+ (just-one-space (if (looking-back "\\s(") 0 1))
(save-excursion
- ;; SWANK:COMPLETE-FORM always returns a closing
- ;; parenthesis; but we only want to insert one if it's
- ;; really necessary (thinking especially of paredit.el.)
- (insert (substring result 0 -1))
+ (insert result)
(let ((slime-close-parens-limit 1))
(slime-close-all-parens-in-sexp)))
(save-excursion
--- /project/slime/cvsroot/slime/contrib/slime-highlight-edits.el 2007/09/20 14:55:53 1.3
+++ /project/slime/cvsroot/slime/contrib/slime-highlight-edits.el 2009/10/31 22:13:55 1.4
@@ -45,7 +45,7 @@
(defun slime-highlight-edits (beg end &optional len)
(save-match-data
(when (and (slime-connected-p)
- (not (slime-inside-comment-p beg end))
+ (not (slime-inside-comment-p))
(not (slime-only-whitespace-p beg end)))
(let ((overlay (make-overlay beg end)))
(overlay-put overlay 'face 'slime-highlight-edits-face)
@@ -71,16 +71,6 @@
(point))))
(slime-remove-edits start end))))
-(defun slime-inside-comment-p (beg end)
- "Is the region from BEG to END in a comment?"
- (save-excursion
- (goto-char beg)
- (let* ((hs-c-start-regexp ";\\|#|")
- (comment (hs-inside-comment-p)))
- (and comment
- (destructuring-bind (cbeg cend) comment
- (<= end cend))))))
-
(defun slime-only-whitespace-p (beg end)
"Contains the region from BEG to END only whitespace?"
(save-excursion
--- /project/slime/cvsroot/slime/contrib/slime-parse.el 2009/10/20 21:28:38 1.24
+++ /project/slime/cvsroot/slime/contrib/slime-parse.el 2009/10/31 22:13:55 1.25
@@ -8,23 +8,8 @@
;;
(defun slime-incomplete-form-at-point ()
- "Looks for a ``raw form spec'' around point to be processed by
-SWANK::PARSE-FORM-SPEC. It is similiar to
-SLIME-INCOMPLETE-SEXP-AT-POINT but looks further back than just
-one sexp to find out the context."
- (multiple-value-bind (operators arg-indices points)
- (slime-enclosing-form-specs)
- (if (null operators)
- ""
- (let ((op (first operators))
- (op-start (first points))
- (arg-index (first arg-indices)))
- (destructure-case (slime-ensure-list op)
- ((:declaration declspec) op)
- ((:type-specifier typespec) op)
- (t
- (slime-make-form-spec-from-string
- (concat (slime-incomplete-sexp-at-point) ")"))))))))
+ (slime-make-form-spec-from-string
+ (concat (slime-incomplete-sexp-at-point) ")")))
(defun slime-parse-sexp-at-point (&optional n skip-blanks-p)
"Returns the sexps at point as a list of strings, otherwise nil.
@@ -246,11 +231,39 @@
string
(let ((n (first (last indices))))
(goto-char (1+ (point-min))) ; `(|OP arg1 ... argN)'
- (mapcar #'(lambda (s)
- (assert (not (equal s string))) ; trap against
- (slime-make-form-spec-from-string s)) ; endless recursion.
- (slime-parse-sexp-at-point (1+ n) t)))))))))
+ (let ((subsexps (slime-parse-sexp-at-point (1+ n) t)))
+ (mapcar #'(lambda (s)
+ (assert (not (equal s string))) ; trap against
+ (slime-make-form-spec-from-string s)) ; endless recursion.
+ subsexps
+ )))))))))
+(defun slime-make-form-spec-from-string (string &optional strip-operator-p)
+ (cond ((slime-length= string 0) "") ; ""
+ ((equal string "()") '()) ; "()"
+ ((eql (char-syntax (aref string 0)) ?\') string) ; "'(foo)", "#(foo)" &c
+ ((not (eql (aref string 0) ?\()) string) ; "foo"
+ (t ; "(op arg1 arg2 ...)"
+ (with-temp-buffer
+ ;; Do NEVER ever try to activate `lisp-mode' here with
+ ;; `slime-use-autodoc-mode' enabled, as this function is used
+ ;; to compute the current autodoc itself.
+ (set-syntax-table lisp-mode-syntax-table)
+ (erase-buffer)
+ (insert string)
+ (goto-char (1+ (point-min)))
+ (let ((subsexps))
+ (while (ignore-errors (slime-forward-sexp) t)
+ (backward-sexp)
+ (push (slime-sexp-at-point) subsexps)
+ (forward-sexp))
+ (mapcar #'(lambda (s)
+ (assert (not (equal s string)))
+ (slime-make-form-spec-from-string s))
+ (nreverse subsexps)))))))
+
+;;; TODO: With the rewrite of autodoc, this function like pretty much
+;;; everything else in this file, is obsolete.
(defun slime-enclosing-form-specs (&optional max-levels)
"Return the list of ``raw form specs'' of all the forms
@@ -351,13 +364,53 @@
(nreverse arg-indices)
(nreverse points))))
+(defun slime-parse-form-upto-point (&optional max-levels)
+ ;; We assert this, because `slime-incomplete-form-at-point' blows up
+ ;; inside a comment.
+ (assert (not (slime-inside-string-or-comment-p)))
+ (save-excursion
+ (let ((char-after (char-after))
+ (char-before (char-before))
+ (marker-suffix (list 'swank::%cursor-marker%)))
+ (cond ((and char-after (eq (char-syntax char-after) ?\())
+ ;; We're at the start of some expression, so make sure
+ ;; that SWANK::%CURSOR-MARKER% will come after that
+ ;; expression.
+ (ignore-errors (forward-sexp)))
+ ((and char-before (eq (char-syntax char-before) ?\ ))
+ ;; We're after some expression, so we have to make sure
+ ;; that %CURSOR-MARKER% does not come directly after that
+ ;; expression.
+ (push "" marker-suffix))
+ ((and char-before (eq (char-syntax char-before) ?\())
+ ;; We're directly after an opening parenthesis, so we
+ ;; have to make sure that something comes before
+ ;; %CURSOR-MARKER%..
+ (push "" marker-suffix))
+ (t
+ ;; We're at a symbol, so make sure we get the whole symbol.
+ (slime-end-of-symbol)))
+ (let ((forms '())
+ (levels (or max-levels 5)))
+ (condition-case nil
+ (let ((form (slime-incomplete-form-at-point)))
+ (setq forms (list (nconc form marker-suffix)))
+ (up-list -1)
+ (dotimes (i (1- levels))
+ (push (slime-incomplete-form-at-point) forms)
+ (up-list -1)))
+ ;; At head of toplevel form.
+ (scan-error nil))
+ (when forms
+ ;; Squeeze list of forms into tree structure again
+ (reduce #'(lambda (form tree)
+ (nconc form (list tree)))
+ forms :from-end t))))))
+
(defun slime-ensure-list (thing)
(if (listp thing) thing (list thing)))
-(defun slime-inside-string-p ()
- (nth 3 (slime-current-parser-state)))
-
(defun slime-beginning-of-string ()
(let* ((parser-state (slime-current-parser-state))
(inside-string-p (nth 3 parser-state))
--- /project/slime/cvsroot/slime/contrib/swank-arglists.lisp 2009/10/31 21:31:49 1.37
+++ /project/slime/cvsroot/slime/contrib/swank-arglists.lisp 2009/10/31 22:13:55 1.38
@@ -2,7 +2,7 @@
;;
;; Authors: Matthias Koeppe <mkoeppe at mail.math.uni-magdeburg.de>
;; Tobias C. Rittweiler <tcr at freebits.de>
-;; and others
+;; and others
;;
;; License: Public Domain
;;
@@ -12,6 +12,8 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(swank-require :swank-c-p-c))
+;;;; Utilities
+
(defun compose (&rest functions)
"Compose FUNCTIONS right-associatively, returning a function"
#'(lambda (x)
@@ -21,21 +23,31 @@
"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
+ (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 ensure-list))
(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))))
+(declaim (inline memq))
+(defun memq (item list)
+ (member item list :test #'eq))
+
+(defun remove-from-tree-if (predicate tree)
+ (cond ((atom tree) tree)
+ ((funcall predicate (car tree))
+ (remove-from-tree-if predicate (cdr tree)))
+ (t
+ (cons (remove-from-tree-if predicate (car tree))
+ (remove-from-tree-if predicate (cdr tree))))))
+
+(defun remove-from-tree (item tree)
+ (remove-from-tree-if #'(lambda (x) (eql x item)) tree))
(defun maybecall (bool fn &rest args)
"Call FN with ARGS if BOOL is T. Otherwise return ARGS as multiple values."
@@ -57,265 +69,40 @@
(macro-function 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?"
(let ((symbol (parse-symbol string)))
(valid-operator-symbol-p symbol)))
(defun valid-function-name-p (form)
- (or (symbolp form)
- (and (consp form)
- (second form)
- (not (third form))
- (eq (first form) 'setf)
- (symbolp (second form)))))
-
-;;; A ``raw form spec'' can be either:
-;;;
-;;; i) a list of strings representing a Common Lisp form
-;;;
-;;; ii) a list of strings as of i), but which additionally
-;;; contains other raw form specs
-;;;
-;;; iii) one of:
-;;;
-;;; a) (:declaration declspec)
-;;;
-;;; where DECLSPEC is a raw form spec.
-;;;
-;;; b) (:type-specifier typespec)
-;;;
-;;; where TYPESPEC is a raw form spec.
-;;;
-;;;
-;;; 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)
-;;;
-;;; ("foo" ("bar" ("quux")) "baz") => (foo (bar (quux)) baz)
-;;;
-;;; (: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)
-;;;
-
-(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."
- (handler-case
- (with-buffer-syntax ()
- (multiple-value-bind (form-spec position newly-interned-symbols)
- (parse-first-valid-form-spec raw-specs #'read-conversatively-for-autodoc)
- (when form-spec
- (unwind-protect
- (let ((arglist (arglist-from-form-spec form-spec :remove-args nil)))
- (unless (eq arglist :not-available)
- (multiple-value-bind (type operator)
- (split-form-spec form-spec)
- (let* ((index (nth position arg-indices))
- (stringified-arglist
- (decoded-arglist-to-string
- arglist
- :operator operator
- :print-right-margin print-right-margin
- :print-lines print-lines
- ;; Do not highlight the operator:
- :highlight (and index (not (zerop index)) index))))
- ;; Post formatting:
- (case type
- (:type-specifier (format nil "[Typespec] ~A" stringified-arglist))
- (:declaration
- (locally (declare (special *arglist-pprint-bindings*))
- (with-bindings *arglist-pprint-bindings*
- ;; Try to print ``(declare (declspec))'' (or ``declaim'' etc.)
- (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 (condition)
- (format nil "ARGLIST (error): ~A" condition))
- ))
-
-(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))))
-
-;; This is a wrapper object around anything that came from Slime and
-;; could not reliably be read.
-(defstruct (arglist-dummy
- (:conc-name #:arglist-dummy.))
- string-representation)
+ (and (match form
+ ((#'symbolp _) t)
+ (('setf (#'symbolp _)) t)
+ (_ nil))
+ (fboundp form)
+ t))
-(defun read-conversatively-for-autodoc (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))
- (prefix (cond ((eql (aref string 0) #\') :quote)
- ((search "#'" string :end2 (min length 2)) :sharpquote)
- (t nil))))
- (multiple-value-bind (symbol found?)
- (parse-symbol (case prefix
- (:quote (subseq string 1))
- (:sharpquote (subseq string 2))
- (t string)))
- (if found?
- (case prefix
- (:quote `(quote ,symbol))
- (:sharpquote `(function ,symbol))
- (t symbol))
- (make-arglist-dummy :string-representation string)))))
+(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 , at rest))))))
+(defmacro with-available-arglist ((var &rest more-vars) form &body body)
+ `(multiple-value-bind (,var , at more-vars) ,form
+ (if (eql ,var :not-available)
+ :not-available
+ (progn #+ignore (assert (arglist-p ,var)) , at body))))
-(defun parse-form-spec (raw-spec &optional reader)
- "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. Symbols that had to be interned
-in course of the conversion, are returned as secondary return value."
- (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)
- (read-form-spec raw-extension reader)
- (unless (recursively-empty-p extension) ; (:DECLARATION (())) &c.
- (destructuring-bind (identifier &rest args) extension
- (values `((,extension-flag ,identifier) , at args)
- introduced-symbols)))))))
- (when (consp raw-spec)
- (destructure-case raw-spec
- ((:declaration raw-declspec)
- (parse-extended-spec raw-declspec :declaration))
- ((:type-specifier raw-typespec)
- (parse-extended-spec raw-typespec :type-specifier))
- (t
- (when (every #'(lambda (x) (or (stringp x) (consp x))) raw-spec)
- (destructuring-bind (raw-operator &rest raw-args) raw-spec
- (multiple-value-bind (operator found?) (parse-symbol raw-operator)
- (when (and found? (valid-operator-symbol-p operator))
- (multiple-value-bind (parsed-args introduced-symbols)
- (read-form-spec raw-args reader)
- (values `(,operator , at parsed-args) introduced-symbols)))))))))))
-
-
-(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 reader)
- "Returns the first parsed form spec in RAW-SPECS that can
-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
-form. As secondary return value, it returns all the symbols that
-had to be newly interned during the conversion.
-
-READER is a function that takes a string, and returns two values:
-the Common Lisp datum that the string represents, a flag whether
-the returned datum is a symbol and has been newly interned in
-some package.
-
-If READER is not explicitly given, the function
-READ-SOFTLY-FROM-STRING* is used instead."
- (when spec
- (with-buffer-syntax ()
- (call-with-ignored-reader-errors
- #'(lambda ()
- (let ((result) (newly-interned-symbols) (ok))
- (unwind-protect
- (dolist (element spec (setq ok t))
- (etypecase element
- (string
- (multiple-value-bind (sexp newly-interned?)
- (funcall (or reader 'read-softly-from-string*) element)
- (push sexp result)
- (when newly-interned?
- (push sexp newly-interned-symbols))))
- (list
- (multiple-value-bind (read-spec interned-symbols)
- (read-form-spec element reader)
- (push read-spec result)
- (setf newly-interned-symbols
- (append interned-symbols
- newly-interned-symbols))))))
- (unless ok
- (mapc #'unintern-in-home-package newly-interned-symbols)))
- (values (nreverse result)
- (nreverse newly-interned-symbols))))))))
-
-(defun read-softly-from-string* (string)
- "Like READ-SOFTLY-FROM-STRING, but only returns the sexp and
-the flag if a symbol had to be interned."
- (multiple-value-bind (sexp pos interned?)
- (read-softly-from-string string)
- ;; To make sure that we haven't got any junk from Emacs.
- (assert (= pos (length string)))
- (values sexp interned?)))
-
-(defun read-softly-from-string (string)
- "Returns three values:
-
- 1. the object resulting from READing STRING.
-
- 2. The index of the first character in STRING that was not read.
-
- 3. T if the object is a symbol that had to be newly interned
- in some package. (This does not work for symbols in
- compound forms like lists or vectors.)"
- (multiple-value-bind (symbol found? symbol-name package) (parse-symbol string)
- (if found?
- (values symbol (length string) nil)
- (multiple-value-bind (sexp pos) (read-from-string string)
- (values sexp pos
- (when (symbolp sexp)
- (prog1 t
- ;; assert that PARSE-SYMBOL didn't parse incorrectly.
- (assert (and (equal symbol-name (symbol-name sexp))
- (eq package (symbol-package sexp)))))))))))
-(defun unintern-in-home-package (symbol)
- (unintern symbol (symbol-package symbol)))
+;;;; Arglist Definition
(defstruct (arglist (:conc-name arglist.) (:predicate arglist-p))
provided-args ; list of the provided actual arguments
@@ -335,7 +122,7 @@
;;;
;;; [*] 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.
+;;; 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
@@ -364,95 +151,214 @@
;;; (DECLARE (OPTIMIZE &ANY (compilation-speed 1) (safety 1) ...))
;;;
-;; FIXME: This really ought to be rewritten.
-(defun print-arglist (arglist &key operator highlight)
- (let ((index 0)
- (need-space nil))
- (labels ((print-arg (arg)
- (typecase arg
- (arglist ; destructuring pattern
- (print-arglist arg))
- (optional-arg
- (let ((enc-arg (encode-optional-arg arg)))
- (if (symbolp enc-arg)
- (princ enc-arg)
- (destructuring-bind (var &optional (initform nil initform-p)) enc-arg
- (pprint-logical-block (nil nil :prefix "(" :suffix ")")
- (format t "~A~:[~; ~S~]" var initform-p initform))))))
- (keyword-arg
- (let ((enc-arg (encode-keyword-arg arg)))
- (etypecase enc-arg
- (symbol (princ enc-arg))
- ((cons symbol)
- (destructuring-bind (keyarg initform) enc-arg
- (pprint-logical-block (nil nil :prefix "(" :suffix ")")
- (format t "~A ~S" keyarg initform))))
- ((cons cons)
- (destructuring-bind ((keyword-name var) &optional (initform nil initform-p))
- enc-arg
- (pprint-logical-block (nil nil :prefix "(" :suffix ")")
- (pprint-logical-block (nil nil :prefix "(" :suffix ")")
- (format t "~S ~A" keyword-name var))
- (when initform-p
- (format t " ~S" initform))))))))
- (t ; required formal or provided actual arg
- (if (keywordp arg)
- (prin1 arg) ; for &ANY args.
- (princ arg)))))
- (print-space ()
- (ecase need-space
- ((nil))
- ((:miser)
- (write-char #\space)
[1496 lines skipped]
More information about the slime-cvs
mailing list