/[slime]/slime/swank.lisp
ViewVC logotype

Diff of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.493 by heller, Thu Aug 23 13:56:22 2007 UTC revision 1.494 by trittweiler, Thu Aug 23 16:19:56 2007 UTC
# Line 390  Useful for low level debugging." Line 390  Useful for low level debugging."
390  (defun ascii-char-p (c)  (defun ascii-char-p (c)
391    (<= (char-code c) 127))    (<= (char-code c) 127))
392    
393    (defun length= (seq n)
394      "Test for whether SEQ contains N number of elements. I.e. it's equivalent
395     to (= (LENGTH SEQ) N), but besides being more concise, it may also be more
396     efficiently implemented."
397      (etypecase seq
398        (list (do ((i n (1- i))
399                   (list seq (cdr list)))
400                  ((or (<= i 0) (null list))
401                   (and (zerop i) (null list)))))
402        (sequence (= (length seq) n))))
403    
404    (defun ensure-list (thing)
405      (if (listp thing) thing (list thing)))
406    
407    (defun recursively-empty-p (list)
408      "Returns whether LIST consists only of arbitrarily nested empty lists."
409      (cond ((not (listp list)) nil)
410            ((null list) t)
411            (t (every #'recursively-empty-p list))))
412    
413    (defun maybecall (bool fn &rest args)
414      "Call FN with ARGS if BOOL is T. Otherwise return ARGS as multiple values."
415      (if bool (apply fn args) (values-list args)))
416    
417    (defun exactly-one-p (&rest values)
418      "If exactly one value in VALUES is non-NIL, this value is returned.
419    Otherwise NIL is returned."
420      (let ((found nil))
421        (dolist (v values)
422          (when v (if found
423                      (return-from exactly-one-p nil)
424                      (setq found v))))
425        found))
426    
427  (defmacro do-symbols* ((var &optional (package '*package*) result-form) &body body)  (defmacro do-symbols* ((var &optional (package '*package*) result-form) &body body)
428    "Just like do-symbols, but makes sure a symbol is visited only once."    "Just like do-symbols, but makes sure a symbol is visited only once."
429    (let ((seen-ht (gensym "SEEN-HT")))    (let ((seen-ht (gensym "SEEN-HT")))
# Line 1513  Return nil if no package matches." Line 1547  Return nil if no package matches."
1547    
1548  ;;;; Arglists  ;;;; Arglists
1549    
1550  (defun find-valid-operator-name (names)  (defslimefun arglist-for-echo-area (raw-specs &key arg-indices
1551    "As a secondary result, returns its index."                                                     print-right-margin print-lines)
1552    (let ((index    "Return the arglist for the first valid ``form spec'' in
1553           (position-if (lambda (name)  RAW-SPECS. A ``form spec'' is a superset of functions, macros,
1554                          (or (consp name)  special-ops, declarations and type specifiers.
1555                              (valid-operator-name-p name)))  
1556                        names)))  For more information about the format of ``raw form specs'' and
1557      (if index  ``form specs'', please see PARSE-FORM-SPEC."
1558          (values (elt names index) index)    (handler-case
         (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  
1559        (with-buffer-syntax ()        (with-buffer-syntax ()
1560          (multiple-value-bind (name which)          (multiple-value-bind (form-spec arg-index)
1561              (find-valid-operator-name names)              (parse-first-valid-form-spec raw-specs arg-indices)
1562            (when which            (when form-spec
1563              (let ((arg-index (and arg-indices (elt arg-indices which))))              (let ((arglist (arglist-from-form-spec form-spec :remove-args nil)))
1564                (multiple-value-bind (form operator-name)                (unless (eql arglist :not-available)
1565                    (operator-designator-to-form name)                  (multiple-value-bind (type operator arguments)
1566                  (let ((*print-right-margin* print-right-margin))                      (split-form-spec form-spec)
1567                    (format-arglist-for-echo-area                    (declare (ignore arguments))
1568                     form operator-name                    (multiple-value-bind (stringified-arglist)
1569                     :print-right-margin print-right-margin                        (decoded-arglist-to-string
1570                     :print-lines print-lines                         arglist
1571                     :highlight (and arg-index                         :operator operator
1572                                     (not (zerop arg-index))                         :print-right-margin print-right-margin
1573                                     ;; don't highlight the operator                         :print-lines print-lines
1574                                     arg-index))))))))                         :highlight (and arg-index
1575                                           (not (zerop arg-index))
1576                                           ;; don't highlight the operator
1577                                           arg-index))
1578                        (case type
1579                          (:declaration    (format nil "(declare ~A)" stringified-arglist))
1580                          (:type-specifier (format nil "[Typespec] ~A" stringified-arglist))
1581                          (t stringified-arglist)))))))))
1582      (error (cond)      (error (cond)
1583        (format nil "ARGLIST: ~A" cond))))        (format nil "ARGLIST (error): ~A" cond))
1584        ))
1585    
1586    (defun parse-form-spec (raw-spec)
1587      "Takes a raw (i.e. unparsed) form spec from SLIME and returns a
1588    proper form spec for further processing within SWANK. Returns NIL
1589    if RAW-SPEC could not be parsed.
1590    
1591    A ``raw form spec'' can be either:
1592    
1593      i)   a string representing a Common Lisp symbol,
1594    
1595      ii)  a string representing a Common Lisp form,
1596    
1597      iii) a list:
1598    
1599         a)  (:declaration declspec)
1600    
1601               where DECLSPEC is the string representation of a /declaration specifier/,
1602    
1603         b)  (:type-specifier typespec)
1604    
1605               where TYPESPEC is the string representation of a /type specifier/.
1606    
1607    
1608    A ``form spec'' is either
1609    
1610      1) a normal Common Lisp form
1611    
1612      2) a Common Lisp form with a list as its CAR specifying what namespace
1613         the operator is supposed to be interpreted in:
1614    
1615           a) ((:declaration decl-identifier) declarg1 declarg2 ...)
1616    
1617           b) ((:type-specifier typespec-op) typespec-arg1 typespec-arg2 ...)
1618    
1619    
1620    Examples:
1621    
1622      \"defmethod\"                       =>  (defmethod)
1623      \"cl:defmethod\"                    =>  (cl:defmethod)
1624      \"(defmethod print-object)\"        =>  (defmethod print-object)
1625      (:declaration \"(optimize)\")       =>  ((:declaration optimize))
1626      (:declaration \"(type string)\")    =>  ((:declaration type) string)
1627      (:type-specifier \"(float)\")       =>  ((:type-specifier float))
1628      (:type-specifier \"(float 0 100)\") =>  ((:type-specifier float) 0 100)
1629    "
1630      (typecase raw-spec
1631        (string (ensure-list (read-incomplete-form-from-string raw-spec)))
1632        (cons                               ; compound form spec
1633         (destructure-case raw-spec
1634           ((:declaration raw-declspec)
1635            (let ((declspec (from-string raw-declspec)))
1636              (unless (recursively-empty-p declspec) ; (:DECLARATION "(())") &c.
1637                (destructuring-bind (decl-identifier &rest decl-args) declspec
1638                  `((:declaration ,decl-identifier) ,@decl-args)))))
1639           ((:type-specifier raw-typespec)
1640            (let ((typespec (from-string raw-typespec)))
1641              (unless (recursively-empty-p typespec)
1642                (destructuring-bind (typespec-op &rest typespec-args) typespec
1643                  `((:type-specifier ,typespec-op) ,@typespec-args)))))))
1644        (otherwise nil)))
1645    
1646    (defun split-form-spec (spec)
1647      "Returns all three relevant information a ``form spec''
1648    contains: the operator type, the operator, and the operands."
1649      (destructuring-bind (operator-designator &rest arguments) spec
1650        (multiple-value-bind (type operator)
1651            (if (listp operator-designator)
1652                (values (first operator-designator) (second operator-designator))
1653                (values :function operator-designator)) ; functions, macros, special ops
1654          (values type operator arguments))))           ;  are all fbound.
1655    
1656    (defun parse-first-valid-form-spec (raw-specs &optional arg-indices)
1657      "Returns the first parsed form spec in RAW-SPECS that can
1658    successfully be parsed. Additionally returns its respective index
1659    in ARG-INDICES (or NIL.)"
1660      (block traversal
1661        (mapc #'(lambda (raw-spec index)
1662                  (let ((spec (parse-form-spec raw-spec)))
1663                    (when spec (return-from traversal
1664                                 (values spec index)))))
1665              raw-specs
1666              (append arg-indices '#1=(nil . #1#)))))
1667    
 (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 ,@args ',(parse-symbol class-name))  
                   operator-name)))  
        ((:defmethod generic-name)  
         (values `(defmethod ,(parse-symbol generic-name))  
                 'defmethod))))  
     (string  
      (values `(,(parse-symbol name))  
              name))))  
1668    
1669  (defun clean-arglist (arglist)  (defun clean-arglist (arglist)
1670    "Remove &whole, &enviroment, and &aux elements from ARGLIST."    "Remove &whole, &enviroment, and &aux elements from ARGLIST."
# Line 1571  Return nil if no package matches." Line 1675  Return nil if no package matches."
1675           '())           '())
1676          (t (cons (car arglist) (clean-arglist (cdr arglist))))))          (t (cons (car arglist) (clean-arglist (cdr arglist))))))
1677    
1678    
1679  (defstruct (arglist (:conc-name arglist.) (:predicate arglist-p))  (defstruct (arglist (:conc-name arglist.) (:predicate arglist-p))
1680    provided-args         ; list of the provided actual arguments    provided-args         ; list of the provided actual arguments
1681    required-args         ; list of the required arguments    required-args         ; list of the required arguments
# Line 1581  Return nil if no package matches." Line 1686  Return nil if no package matches."
1686    body-p                ; whether the rest argument is a &body    body-p                ; whether the rest argument is a &body
1687    allow-other-keys-p    ; whether &allow-other-keys appeared    allow-other-keys-p    ; whether &allow-other-keys appeared
1688    aux-args              ; list of &aux variables    aux-args              ; list of &aux variables
1689      any-p                 ; whether &any appeared
1690      any-args              ; list of &any arguments  [*]
1691    known-junk            ; &whole, &environment    known-junk            ; &whole, &environment
1692    unknown-junk)         ; unparsed stuff    unknown-junk)         ; unparsed stuff
1693    
1694    ;;;
1695    ;;; [*] The &ANY lambda keyword is an extension to ANSI Common Lisp,
1696    ;;;     and is only used to describe certain arglists that cannot be
1697    ;;;     described in another way.
1698    ;;;
1699    ;;;     &ANY is very similiar to &KEY but while &KEY is based upon
1700    ;;;     the idea of a plist (key1 value1 key2 value2), &ANY is a
1701    ;;;     cross between &OPTIONAL, &KEY and *FEATURES* lists:
1702    ;;;
1703    ;;;        a) (&ANY :A :B :C) means that you can provide any (non-null)
1704    ;;;              set consisting of the keywords `:A', `:B', or `:C' in
1705    ;;;              the arglist. E.g. (:A) or (:C :B :A).
1706    ;;;
1707    ;;;        (This is not restricted to keywords only, but any self-evaluating
1708    ;;;         expression is allowed.)
1709    ;;;
1710    ;;;        b) (&ANY (key1 v1) (key2 v2) (key3 v3)) means that you can
1711    ;;;              provide any (non-null) set consisting of lists where
1712    ;;;              the CAR of the list is one of `key1', `key2', or `key3'.
1713    ;;;              E.g. ((key1 100) (key3 42)), or ((key3 66) (key2 23))
1714    ;;;
1715    ;;;
1716    ;;;     For example, a) let us describe the situations of EVAL-WHEN as
1717    ;;;
1718    ;;;       (EVAL-WHEN (&ANY :compile-toplevel :load-toplevel :execute) &BODY body)
1719    ;;;
1720    ;;;     and b) let us describe the optimization qualifiers that are valid
1721    ;;;     in the declaration specifier `OPTIMIZE':
1722    ;;;
1723    ;;;       (DECLARE (OPTIMIZE &ANY (compilation-speed 1) (safety 1) ...))
1724    ;;;
1725    
1726  (defun print-arglist (arglist &key operator highlight)  (defun print-arglist (arglist &key operator highlight)
1727    (let ((index 0)    (let ((index 0)
1728          (need-space nil))          (need-space nil))
# Line 1654  Return nil if no package matches." Line 1793  Return nil if no package matches."
1793                  (arglist.keyword-args arglist)))                  (arglist.keyword-args arglist)))
1794          (when (arglist.allow-other-keys-p arglist)          (when (arglist.allow-other-keys-p arglist)
1795            (print-with-space '&allow-other-keys))            (print-with-space '&allow-other-keys))
1796            (when (arglist.any-args arglist)
1797              (print-with-space '&any)
1798              (mapc #'print-with-space
1799                    (arglist.any-args arglist)))
1800          (cond ((not (arglist.rest arglist)))          (cond ((not (arglist.rest arglist)))
1801                ((arglist.body-p arglist)                ((arglist.body-p arglist)
1802                 (print-with-space '&body)                 (print-with-space '&body)
# Line 1664  Return nil if no package matches." Line 1807  Return nil if no package matches."
1807          (mapc #'print-with-space          (mapc #'print-with-space
1808                (arglist.unknown-junk arglist))))))                (arglist.unknown-junk arglist))))))
1809    
1810  (defun decoded-arglist-to-string (arglist package  (defun decoded-arglist-to-string (arglist
1811                                    &key operator print-right-margin                                    &key operator highlight (package *package*)
1812                                    print-lines highlight)                                    print-right-margin print-lines)
1813    "Print the decoded ARGLIST for display in the echo area.  The    "Print the decoded ARGLIST for display in the echo area.  The
1814  argument name are printed without package qualifiers and pretty  argument name are printed without package qualifiers and pretty
1815  printing of (function foo) as #'foo is suppressed.  If HIGHLIGHT is  printing of (function foo) as #'foo is suppressed.  If HIGHLIGHT is
# Line 1678  If OPERATOR is non-nil, put it in front Line 1821  If OPERATOR is non-nil, put it in front
1821              (*print-pretty* t) (*print-circle* nil) (*print-readably* nil)              (*print-pretty* t) (*print-circle* nil) (*print-readably* nil)
1822              (*print-level* 10) (*print-length* 20)              (*print-level* 10) (*print-length* 20)
1823              (*print-right-margin* print-right-margin)              (*print-right-margin* print-right-margin)
1824              (*print-lines* print-lines))              (*print-lines* print-lines)
1825                (*print-escape* nil))       ; no package qualifies.
1826          (print-arglist arglist :operator operator :highlight highlight)))))          (print-arglist arglist :operator operator :highlight highlight)))))
1827    
1828  (defslimefun variable-desc-for-echo-area (variable-name)  (defslimefun variable-desc-for-echo-area (variable-name)
# Line 1813  Return an OPTIONAL-ARG structure." Line 1957  Return an OPTIONAL-ARG structure."
1957          ((member arg '(&whole &environment))          ((member arg '(&whole &environment))
1958           (setq mode arg)           (setq mode arg)
1959           (push arg (arglist.known-junk result)))           (push arg (arglist.known-junk result)))
1960            ((and (symbolp arg)
1961                  (string= (symbol-name arg) (string '#:&ANY))) ; may be interned
1962             (setf (arglist.any-p result) t)                    ;  in any *package*.
1963             (setq mode '&any))
1964          ((member arg lambda-list-keywords)          ((member arg lambda-list-keywords)
1965           (setq mode '&unknown-junk)           (setq mode '&unknown-junk)
1966           (push arg (arglist.unknown-junk result)))           (push arg (arglist.unknown-junk result)))
# Line 1837  Return an OPTIONAL-ARG structure." Line 1985  Return an OPTIONAL-ARG structure."
1985                    (arglist.required-args result)))                    (arglist.required-args result)))
1986             ((&whole &environment)             ((&whole &environment)
1987              (setf mode nil)              (setf mode nil)
1988              (push arg (arglist.known-junk result)))))))              (push arg (arglist.known-junk result)))
1989               (&any
1990                (push arg (arglist.any-args result)))))))
1991      (nreversef (arglist.required-args result))      (nreversef (arglist.required-args result))
1992      (nreversef (arglist.optional-args result))      (nreversef (arglist.optional-args result))
1993      (nreversef (arglist.keyword-args result))      (nreversef (arglist.keyword-args result))
1994      (nreversef (arglist.aux-args result))      (nreversef (arglist.aux-args result))
1995        (nreversef (arglist.any-args result))
1996      (nreversef (arglist.known-junk result))      (nreversef (arglist.known-junk result))
1997      (nreversef (arglist.unknown-junk result))      (nreversef (arglist.unknown-junk result))
1998        (assert (or (and (not (arglist.key-p result)) (not (arglist.any-p result)))
1999                    (exactly-one-p (arglist.key-p result) (arglist.any-p result))))
2000      result))      result))
2001    
2002  (defun encode-arglist (decoded-arglist)  (defun encode-arglist (decoded-arglist)
# Line 1856  Return an OPTIONAL-ARG structure." Line 2009  Return an OPTIONAL-ARG structure."
2009            (mapcar #'encode-keyword-arg (arglist.keyword-args decoded-arglist))            (mapcar #'encode-keyword-arg (arglist.keyword-args decoded-arglist))
2010            (when (arglist.allow-other-keys-p decoded-arglist)            (when (arglist.allow-other-keys-p decoded-arglist)
2011              '(&allow-other-keys))              '(&allow-other-keys))
2012              (when (arglist.any-args decoded-arglist)
2013                `(&any ,@(arglist.any-args decoded-arglist)))
2014            (cond ((not (arglist.rest decoded-arglist))            (cond ((not (arglist.rest decoded-arglist))
2015                   '())                   '())
2016                  ((arglist.body-p decoded-arglist)                  ((arglist.body-p decoded-arglist)
# Line 1946  whether &allow-other-keys appears somewh Line 2101  whether &allow-other-keys appears somewh
2101              (format t "~W "              (format t "~W "
2102                      (if (keywordp keyword) keyword `',keyword))                      (if (keywordp keyword) keyword `',keyword))
2103              (print-arg-or-pattern arg-name)))              (print-arg-or-pattern arg-name)))
2104            (dolist (any-arg (arglist.any-args decoded-arglist))
2105              (space)
2106              (print-arg-or-pattern any-arg))
2107          (when (and (arglist.rest decoded-arglist)          (when (and (arglist.rest decoded-arglist)
2108                     (or (not (arglist.keyword-args decoded-arglist))                     (or (not (arglist.keyword-args decoded-arglist))
2109                         (arglist.allow-other-keys-p decoded-arglist)))                         (arglist.allow-other-keys-p decoded-arglist)))
# Line 1955  whether &allow-other-keys appears somewh Line 2113  whether &allow-other-keys appears somewh
2113            (format t "~A..." (arglist.rest decoded-arglist)))))            (format t "~A..." (arglist.rest decoded-arglist)))))
2114      (pprint-newline :fill)))      (pprint-newline :fill)))
2115    
2116    
2117  (defgeneric extra-keywords (operator &rest args)  (defgeneric extra-keywords (operator &rest args)
2118     (:documentation "Return a list of extra keywords of OPERATOR (a     (:documentation "Return a list of extra keywords of OPERATOR (a
2119  symbol) when applied to the (unevaluated) ARGS.  symbol) when applied to the (unevaluated) ARGS.
# Line 1962  As a secondary value, return whether oth Line 2121  As a secondary value, return whether oth
2121  As a tertiary value, return the initial sublist of ARGS that was needed  As a tertiary value, return the initial sublist of ARGS that was needed
2122  to determine the extra keywords."))  to determine the extra keywords."))
2123    
2124    (defun keywords-of-operator (operator)
2125      "Return a list of KEYWORD-ARGs that OPERATOR accepts.
2126    This function is useful for writing EXTRA-KEYWORDS methods for
2127    user-defined functions which are declared &ALLOW-OTHER-KEYS and which
2128    forward keywords to OPERATOR."
2129      (let ((arglist (arglist-from-form-spec (ensure-list operator)
2130                                             :remove-args nil)))
2131        (unless (eql arglist :not-available)
2132          (values
2133           (arglist.keyword-args arglist)
2134           (arglist.allow-other-keys-p arglist)))))
2135    
2136  (defmethod extra-keywords (operator &rest args)  (defmethod extra-keywords (operator &rest args)
2137    ;; default method    ;; default method
2138    (declare (ignore args))    (declare (ignore args))
# Line 2164  If the arglist is not available, return Line 2335  If the arglist is not available, return
2335                                               argument-forms)                                               argument-forms)
2336    (let ((function-name-form (car argument-forms)))    (let ((function-name-form (car argument-forms)))
2337      (when (and (listp function-name-form)      (when (and (listp function-name-form)
2338                 (= (length function-name-form) 2)                 (length= function-name-form 2)
2339                 (member (car function-name-form) '(quote function)))                 (member (car function-name-form) '(quote function)))
2340        (let ((function-name (cadr function-name-form)))        (let ((function-name (cadr function-name-form)))
2341          (when (valid-operator-symbol-p function-name)          (when (valid-operator-symbol-p function-name)
# Line 2214  If the arglist is not available, return Line 2385  If the arglist is not available, return
2385  (defun remove-actual-args (decoded-arglist actual-arglist)  (defun remove-actual-args (decoded-arglist actual-arglist)
2386    "Remove from DECODED-ARGLIST the arguments that have already been    "Remove from DECODED-ARGLIST the arguments that have already been
2387  provided in ACTUAL-ARGLIST."  provided in ACTUAL-ARGLIST."
2388      (assert (or (and (not (arglist.key-p decoded-arglist))
2389                       (not (arglist.any-p decoded-arglist)))
2390                  (exactly-one-p (arglist.key-p decoded-arglist)
2391                                 (arglist.any-p decoded-arglist))))
2392    (loop while (and actual-arglist    (loop while (and actual-arglist
2393                     (arglist.required-args decoded-arglist))                     (arglist.required-args decoded-arglist))
2394       do (progn (pop actual-arglist)       do (progn (pop actual-arglist)
# Line 2222  provided in ACTUAL-ARGLIST." Line 2397  provided in ACTUAL-ARGLIST."
2397                     (arglist.optional-args decoded-arglist))                     (arglist.optional-args decoded-arglist))
2398       do (progn (pop actual-arglist)       do (progn (pop actual-arglist)
2399                 (pop (arglist.optional-args decoded-arglist))))                 (pop (arglist.optional-args decoded-arglist))))
2400    (loop for keyword in actual-arglist by #'cddr    (if (arglist.any-p decoded-arglist)
2401       for keywords-to-remove = (cdr (assoc keyword *remove-keywords-alist*))        (remove-&any-args decoded-arglist actual-arglist)
2402       do (setf (arglist.keyword-args decoded-arglist)        (remove-&key-args decoded-arglist actual-arglist))
2403                (remove-if (lambda (kw)    decoded-arglist)
2404                             (or (eql kw keyword)  
2405                                 (member kw keywords-to-remove)))  (defun remove-&key-args (decoded-arglist key-args)
2406                           (arglist.keyword-args decoded-arglist)    (loop for keyword in key-args by #'cddr
2407                           :key #'keyword-arg.keyword))))          for keywords-to-remove = (cdr (assoc keyword *remove-keywords-alist*))
2408            do (setf (arglist.keyword-args decoded-arglist)
2409                     (remove-if (lambda (kw)
2410                                  (or (eql kw keyword)
2411                                      (member kw keywords-to-remove)))
2412                                (arglist.keyword-args decoded-arglist)
2413                                :key #'keyword-arg.keyword)))  )
2414    
2415    (defun remove-&any-args (decoded-arglist any-args)
2416      (setf (arglist.any-args decoded-arglist)
2417            (remove-if #'(lambda (x) (member x any-args))
2418                       (arglist.any-args decoded-arglist)
2419                       :key #'(lambda (x) (first (ensure-list x))))))
2420    
2421    
2422  (defgeneric form-completion (operator-form argument-forms &key remove-args))  (defun arglist-from-form-spec (form-spec &key (remove-args t))
2423      "Returns the decoded arglist that corresponds to FORM-SPEC. If
2424    REMOVE-ARGS is T, the arguments that are contained in FORM-SPEC
2425    are removed from the result arglist.
2426    
2427    Examples:
2428    
2429      (arglist-from-form-spec '(defun))
2430    
2431          ~=> (name args &body body)
2432    
2433      (arglist-from-form-spec '(defun foo))
2434    
2435          ~=> (args &body body))
2436    
2437      (arglist-from-form-spec '(defun foo) :remove-args nil)
2438    
2439          ~=>  (name args &body body))
2440    
2441      (arglist-from-form-spec '((:type-specifier float) 42) :remove-args nil)
2442    
2443          ~=> (&optional lower-limit upper-limit)
2444    "
2445      (if (null form-spec)
2446          :not-available
2447          (multiple-value-bind (type operator arguments)
2448              (split-form-spec form-spec)
2449            (arglist-dispatch type operator arguments :remove-args remove-args))))
2450    
2451    
2452    (defmacro with-availability ((var) form &body body)
2453      `(let ((,var ,form))
2454         (if (eql ,var :not-available)
2455             :not-available
2456             (progn ,@body))))
2457    
2458    (defgeneric arglist-dispatch (operator-type operator arguments &key remove-args))
2459    
2460  (defmethod form-completion (operator-form argument-forms &key (remove-args t))  (defmethod arglist-dispatch (operator-type operator arguments &key (remove-args t))
2461    (when (and (symbolp operator-form)    (when (and (symbolp operator)
2462               (valid-operator-symbol-p operator-form))               (valid-operator-symbol-p operator))
2463      (multiple-value-bind (decoded-arglist determining-args any-enrichment)      (multiple-value-bind (decoded-arglist determining-args any-enrichment)
2464          (compute-enriched-decoded-arglist operator-form argument-forms)          (compute-enriched-decoded-arglist operator arguments)
2465        (etypecase decoded-arglist        (etypecase decoded-arglist
2466          ((member :not-available)          ((member :not-available)
2467           :not-available)           :not-available)
# Line 2245  provided in ACTUAL-ARGLIST." Line 2469  provided in ACTUAL-ARGLIST."
2469           (cond           (cond
2470             (remove-args             (remove-args
2471              ;; get rid of formal args already provided              ;; get rid of formal args already provided
2472              (remove-actual-args decoded-arglist argument-forms))              (remove-actual-args decoded-arglist arguments))
2473             (t             (t
2474              ;; replace some formal args by determining actual args              ;; replace some formal args by determining actual args
2475              (remove-actual-args decoded-arglist determining-args)              (remove-actual-args decoded-arglist determining-args)
2476              (setf (arglist.provided-args decoded-arglist)              (setf (arglist.provided-args decoded-arglist)
2477                    determining-args)))                    determining-args)))
2478           (return-from form-completion           (return-from arglist-dispatch
2479             (values decoded-arglist any-enrichment))))))             (values decoded-arglist any-enrichment))))))
2480    :not-available)    :not-available)
2481    
2482  (defmethod form-completion ((operator-form (eql 'defmethod))  (defmethod arglist-dispatch ((operator-type (eql :function)) (operator (eql 'defmethod))
2483                              argument-forms &key (remove-args t))                               arguments &key (remove-args t))
2484    (when (and (listp argument-forms)    (when (and (listp arguments)
2485               (not (null argument-forms)) ;have generic function name               (not (null arguments)) ;have generic function name
2486               (notany #'listp (rest argument-forms))) ;don't have arglist yet               (notany #'listp (rest arguments))) ;don't have arglist yet
2487      (let* ((gf-name (first argument-forms))      (let* ((gf-name (first arguments))
2488             (gf (and (or (symbolp gf-name)             (gf (and (or (symbolp gf-name)
2489                          (and (listp gf-name)                          (and (listp gf-name)
2490                               (eql (first gf-name) 'setf)))                               (eql (first gf-name) 'setf)))
2491                      (fboundp gf-name)                      (fboundp gf-name)
2492                      (fdefinition gf-name))))                      (fdefinition gf-name))))
2493        (when (typep gf 'generic-function)        (when (typep gf 'generic-function)
2494          (let ((arglist (arglist gf)))          (with-availability (arglist) (arglist gf)
2495            (etypecase arglist            (return-from arglist-dispatch
2496              ((member :not-available))              (values (make-arglist :provided-args (if remove-args
2497              (list                                                       nil
2498               (return-from form-completion                                                       (list gf-name))
2499                 (values (make-arglist :provided-args (if remove-args                                    :required-args (list arglist)
2500                                                          nil                                    :rest "body" :body-p t)
2501                                                          (list gf-name))                      t))))))
                                      :required-args (list arglist)  
                                      :rest "body" :body-p t)  
                        t))))))))  
2502    (call-next-method))    (call-next-method))
2503    
2504    (defmethod arglist-dispatch ((operator-type (eql :declaration))
2505                                 decl-identifier decl-args &key (remove-args t))
2506      (with-availability (arglist)
2507          (declaration-arglist decl-identifier)
2508        (maybecall remove-args #'remove-actual-args
2509                   (decode-arglist arglist) decl-args))
2510      ;; We don't fall back to CALL-NEXT-METHOD because we're within a
2511      ;; different namespace!
2512      )
2513    
2514    (defmethod arglist-dispatch ((operator-type (eql :type-specifier))
2515                                 type-specifier specifier-args &key (remove-args t))
2516      (with-availability (arglist)
2517          (type-specifier-arglist type-specifier)
2518        (maybecall remove-args #'remove-actual-args
2519                   (decode-arglist arglist) specifier-args))
2520      ;; No CALL-NEXT-METHOD, see above.
2521      )
2522    
2523    
2524  (defun read-incomplete-form-from-string (form-string)  (defun read-incomplete-form-from-string (form-string)
2525    (with-buffer-syntax ()    (with-buffer-syntax ()
2526      (handler-case      (handler-case
# Line 2291  provided in ACTUAL-ARGLIST." Line 2532  provided in ACTUAL-ARGLIST."
2532          (declare (ignore c))          (declare (ignore c))
2533          nil))))          nil))))
2534    
2535    
2536  (defslimefun complete-form (form-string)  (defslimefun complete-form (form-string)
2537    "Read FORM-STRING in the current buffer package, then complete it    "Read FORM-STRING in the current buffer package, then complete it
2538  by adding a template for the missing arguments."  by adding a template for the missing arguments."
2539    (let ((form (read-incomplete-form-from-string form-string)))    (let ((form (parse-form-spec form-string)))
2540      (when (consp form)      (when (consp form)
2541        (let ((operator-form (first form))        (let ((form-completion (arglist-from-form-spec form)))
             (argument-forms (rest form)))  
         (let ((form-completion  
                (form-completion operator-form argument-forms)))  
           (unless (eql form-completion :not-available)  
             (return-from complete-form  
               (decoded-arglist-to-template-string form-completion  
                                                   *buffer-package*  
                                                   :prefix ""))))))  
     :not-available))  
   
 (defun format-arglist-for-echo-area (form operator-name  
                                      &key print-right-margin print-lines  
                                      highlight)  
   "Return the arglist for FORM as a string."  
   (when (consp form)  
     (destructuring-bind (operator-form &rest argument-forms)  
         form  
       (let ((form-completion  
              (form-completion operator-form argument-forms  
                               :remove-args nil)))  
2542          (unless (eql form-completion :not-available)          (unless (eql form-completion :not-available)
2543            (return-from format-arglist-for-echo-area            (return-from complete-form
2544              (decoded-arglist-to-string              (decoded-arglist-to-template-string form-completion
2545               form-completion                                                  *buffer-package*
2546               *package*                                                  :prefix "")))))
2547               :operator operator-name      :not-available))
              :print-right-margin print-right-margin  
              :print-lines print-lines  
              :highlight highlight))))))  
   nil)  
2548    
 (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 (form-completion operator nil  
                                   :remove-args nil)))  
     (unless (eql arglist :not-available)  
       (values  
        (arglist.keyword-args arglist)  
        (arglist.allow-other-keys-p arglist)))))  
2549    
2550  (defun arglist-ref (decoded-arglist operator &rest indices)  (defun arglist-ref (decoded-arglist operator &rest indices)
2551    (cond    (cond
# Line 2354  forward keywords to OPERATOR." Line 2561  forward keywords to OPERATOR."
2561           (let ((arg (elt args index)))           (let ((arg (elt args index)))
2562             (apply #'arglist-ref arg nil (rest indices))))))))             (apply #'arglist-ref arg nil (rest indices))))))))
2563    
2564  (defslimefun completions-for-keyword (names keyword-string arg-indices)  (defslimefun completions-for-keyword (raw-specs keyword-string arg-indices)
2565    (with-buffer-syntax ()    (with-buffer-syntax ()
2566      (multiple-value-bind (name index)      (multiple-value-bind (form-spec index)
2567          (find-valid-operator-name names)          (parse-first-valid-form-spec raw-specs arg-indices)
2568        (when name        (when form-spec
2569          (let* ((form (operator-designator-to-form name))          (let ((arglist   (arglist-from-form-spec form-spec  :remove-args nil)))
                (operator-form (first form))  
                (argument-forms (rest form))  
                (arglist  
                 (form-completion operator-form argument-forms  
                                  :remove-args nil)))  
2570            (unless (eql arglist :not-available)            (unless (eql arglist :not-available)
2571              (let* ((indices (butlast (reverse (last arg-indices (1+ index)))))              (multiple-value-bind (type operator arguments) (split-form-spec form-spec)
2572                     (arglist (apply #'arglist-ref arglist operator-form indices)))                (declare (ignore type arguments))
2573                (when (and arglist (arglist-p arglist))                (let* ((indices (butlast (reverse (last arg-indices (1+ index)))))
2574                  ;; It would be possible to complete keywords only if we                       (arglist (apply #'arglist-ref arglist operator indices)))
2575                  ;; are in a keyword position, but it is not clear if we                  (when (and arglist (arglist-p arglist))
2576                  ;; want that.                    ;; It would be possible to complete keywords only if we
2577                  (let* ((keywords                    ;; are in a keyword position, but it is not clear if we
2578                          (mapcar #'keyword-arg.keyword                    ;; want that.
2579                                  (arglist.keyword-args arglist)))                    (let* ((keywords
2580                         (keyword-name                            (mapcar #'keyword-arg.keyword
2581                          (tokenize-symbol keyword-string))                                    (arglist.keyword-args arglist)))
2582                         (matching-keywords                           (keyword-name
2583                          (find-matching-symbols-in-list keyword-name keywords                            (tokenize-symbol keyword-string))
2584                                                         #'compound-prefix-match))                           (matching-keywords
2585                         (converter (completion-output-symbol-converter keyword-string))                            (find-matching-symbols-in-list keyword-name keywords
2586                         (strings                                                           #'compound-prefix-match))
2587                          (mapcar converter                           (converter (completion-output-symbol-converter keyword-string))
2588                                  (mapcar #'symbol-name matching-keywords)))                           (strings
2589                         (completion-set                            (mapcar converter
2590                          (format-completion-set strings nil "")))                                    (mapcar #'symbol-name matching-keywords)))
2591                    (list completion-set                           (completion-set
2592                          (longest-compound-prefix completion-set)))))))))))                            (format-completion-set strings nil "")))
2593                        (list completion-set
2594                              (longest-compound-prefix completion-set))))))))))))
2595    
2596    
2597  (defun arglist-to-string (arglist package &key print-right-margin highlight)  (defun arglist-to-string (arglist package &key print-right-margin highlight)
2598    (decoded-arglist-to-string (decode-arglist arglist)    (decoded-arglist-to-string (decode-arglist arglist)
2599                               package                               :package package
2600                               :print-right-margin print-right-margin                               :print-right-margin print-right-margin
2601                               :highlight highlight))                               :highlight highlight))
2602    
# Line 2546  Errors are trapped and invoke our debugg Line 2750  Errors are trapped and invoke our debugg
2750    (with-buffer-syntax ()    (with-buffer-syntax ()
2751      (let ((*print-readably* nil))      (let ((*print-readably* nil))
2752        (cond ((null values) "; No value")        (cond ((null values) "; No value")
2753              ((and (null (cdr values)) (integerp (car values)))              ((and (length= values 1)  (integerp (car values)))
2754               (let ((i (car values)))               (let ((i (car values)))
2755                 (format nil "~A~D (#x~X, #o~O, #b~B)"                 (format nil "~A~D (#x~X, #o~O, #b~B)"
2756                         *echo-area-prefix* i i i i)))                         *echo-area-prefix* i i i i)))

Legend:
Removed from v.1.493  
changed lines
  Added in v.1.494

  ViewVC Help
Powered by ViewVC 1.1.5