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

Diff of /slime/swank.lisp

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

revision 1.386 by mkoeppe, Thu Jul 13 20:09:09 2006 UTC revision 1.387 by mkoeppe, Mon Jul 24 14:01:15 2006 UTC
# Line 1378  Return the package or nil." Line 1378  Return the package or nil."
1378    
1379  ;;;; Arglists  ;;;; Arglists
1380    
1381    (defun find-valid-operator-name (names)
1382      "As a secondary result, returns its index."
1383      (let ((index
1384             (position-if (lambda (name)
1385                            (or (consp name)
1386                                (valid-operator-name-p name)))
1387                          names)))
1388        (if index
1389            (values (elt names index) index)
1390            (values nil nil))))
1391    
1392  (defslimefun arglist-for-echo-area (names &key print-right-margin  (defslimefun arglist-for-echo-area (names &key print-right-margin
1393                                            print-lines arg-indices)                                            print-lines arg-indices)
1394    "Return the arglist for the first function, macro, or special-op in NAMES."    "Return the arglist for the first function, macro, or special-op in NAMES."
1395    (handler-case    (handler-case
1396        (with-buffer-syntax ()        (with-buffer-syntax ()
1397          (let ((which (position-if (lambda (name)          (multiple-value-bind (name which)
1398                                      (or (consp name)              (find-valid-operator-name names)
                                         (valid-operator-name-p name)))  
                                   names)))  
1399            (when which            (when which
1400              (let ((name (elt names which))              (let ((arg-index (and arg-indices (elt arg-indices which))))
                   (arg-index (and arg-indices (elt arg-indices which))))  
1401                (multiple-value-bind (form operator-name)                (multiple-value-bind (form operator-name)
1402                    (operator-designator-to-form name)                    (operator-designator-to-form name)
1403                  (let ((*print-right-margin* print-right-margin))                  (let ((*print-right-margin* print-right-margin))
# Line 1428  Return the package or nil." Line 1436  Return the package or nil."
1436           '())           '())
1437          (t (cons (car arglist) (clean-arglist (cdr arglist))))))          (t (cons (car arglist) (clean-arglist (cdr arglist))))))
1438    
1439    (defstruct (arglist (:conc-name arglist.) (:predicate arglist-p))
1440      provided-args         ; list of the provided actual arguments
1441      required-args         ; list of the required arguments
1442      optional-args         ; list of the optional arguments
1443      key-p                 ; whether &key appeared
1444      keyword-args          ; list of the keywords
1445      rest                  ; name of the &rest or &body argument (if any)
1446      body-p                ; whether the rest argument is a &body
1447      allow-other-keys-p    ; whether &allow-other-keys appeared
1448      aux-args              ; list of &aux variables
1449      known-junk            ; &whole, &environment
1450      unknown-junk)         ; unparsed stuff
1451    
1452    (defun print-arglist (arglist &key operator highlight)
1453      (let ((index 0)
1454            (need-space nil))
1455        (labels ((print-arg (arg)
1456                   (etypecase arg
1457                     (arglist               ; destructuring pattern
1458                      (print-arglist arg))
1459                     (optional-arg
1460                      (princ (encode-optional-arg arg)))
1461                     (keyword-arg
1462                      (let ((enc-arg (encode-keyword-arg arg)))
1463                        (etypecase enc-arg
1464                          (symbol (princ enc-arg))
1465                          ((cons symbol)
1466                           (pprint-logical-block (nil nil :prefix "(" :suffix ")")
1467                             (princ (car enc-arg))
1468                             (write-char #\space)
1469                             (pprint-fill *standard-output* (cdr enc-arg) nil)))
1470                          ((cons cons)
1471                           (pprint-logical-block (nil nil :prefix "(" :suffix ")")
1472                             (pprint-logical-block (nil nil :prefix "(" :suffix ")")
1473                               (prin1 (caar enc-arg))
1474                               (write-char #\space)
1475                               (print-arg (keyword-arg.arg-name arg)))
1476                             (unless (null (cdr enc-arg))
1477                               (write-char #\space))
1478                             (pprint-fill *standard-output* (cdr enc-arg) nil))))))
1479                     (t           ; required formal or provided actual arg
1480                      (princ arg))))
1481                 (print-space ()
1482                   (ecase need-space
1483                     ((nil))
1484                     ((:miser)
1485                      (write-char #\space)
1486                      (pprint-newline :miser))
1487                     ((t)
1488                      (write-char #\space)
1489                      (pprint-newline :fill)))
1490                   (setq need-space t))
1491                 (print-with-space (obj)
1492                   (print-space)
1493                   (print-arg obj))
1494                 (print-with-highlight (arg &optional (index-ok-p #'=))
1495                   (print-space)
1496                   (cond
1497                     ((and highlight (funcall index-ok-p index highlight))
1498                      (princ "===> ")
1499                      (print-arg arg)
1500                      (princ " <==="))
1501                     (t
1502                      (print-arg arg)))
1503                   (incf index)))
1504          (pprint-logical-block (nil nil :prefix "(" :suffix ")")
1505            (when operator
1506              (print-with-highlight operator)
1507              (setq need-space :miser))
1508            (mapc #'print-with-highlight
1509                  (arglist.provided-args arglist))
1510            (mapc #'print-with-highlight
1511                  (arglist.required-args arglist))
1512            (when (arglist.optional-args arglist)
1513              (print-with-space '&optional)
1514              (mapc #'print-with-highlight
1515                    (arglist.optional-args arglist)))
1516            (when (arglist.key-p arglist)
1517              (print-with-space '&key)
1518              (mapc #'print-with-space
1519                    (arglist.keyword-args arglist)))
1520            (when (arglist.allow-other-keys-p arglist)
1521              (print-with-space '&allow-other-keys))
1522            (cond ((not (arglist.rest arglist)))
1523                  ((arglist.body-p arglist)
1524                   (print-with-space '&body)
1525                   (print-with-highlight (arglist.rest arglist) #'<=))
1526                  (t
1527                   (print-with-space '&rest)
1528                   (print-with-highlight (arglist.rest arglist) #'<=)))
1529            (mapc #'print-with-space
1530                  (arglist.unknown-junk arglist))))))
1531    
1532  (defun decoded-arglist-to-string (arglist package  (defun decoded-arglist-to-string (arglist package
1533                                    &key operator print-right-margin                                    &key operator print-right-margin
1534                                    print-lines highlight)                                    print-lines highlight)
# Line 1443  If OPERATOR is non-nil, put it in front Line 1544  If OPERATOR is non-nil, put it in front
1544              (*print-level* 10) (*print-length* 20)              (*print-level* 10) (*print-length* 20)
1545              (*print-right-margin* print-right-margin)              (*print-right-margin* print-right-margin)
1546              (*print-lines* print-lines))              (*print-lines* print-lines))
1547          (let ((index 0)          (print-arglist arglist :operator operator :highlight highlight)))))
               (first-arg t))  
           (labels ((print-arg (arg)  
                      (etypecase arg  
                        (symbol (princ arg))  
                        (string (princ arg))  
                        (cons (pprint-logical-block (nil nil :prefix "(" :suffix ")")  
                                (princ (car arg))  
                                (unless (null (cdr arg))  
                                  (write-char #\space))  
                                (pprint-fill *standard-output* (cdr arg) nil)))))  
                    (print-space ()  
                      (unless first-arg  
                        (write-char #\space)  
                        (pprint-newline :fill))  
                      (setf first-arg nil))  
                    (print-with-space (obj)  
                      (print-space)  
                      (print-arg obj))  
                    (print-keyword-arg-with-space (arg)  
                      (print-space)  
                      (etypecase arg  
                        (symbol (princ arg))  
                        ((cons symbol)  
                         (pprint-logical-block (nil nil :prefix "(" :suffix ")")  
                           (princ (car arg))  
                           (write-char #\space)  
                           (pprint-fill *standard-output* (cdr arg) nil)))  
                        ((cons cons)  
                         (pprint-logical-block (nil nil :prefix "(" :suffix ")")  
                           (pprint-logical-block (nil nil :prefix "(" :suffix ")")  
                             (prin1 (caar arg))  
                             (write-char #\space)  
                             (princ (cadar arg)))  
                           (unless (null (cdr arg))  
                             (write-char #\space))  
                           (pprint-fill *standard-output* (cdr arg) nil)))))  
                    (print-with-highlight (arg &optional (index-ok-p #'=)  
                                               (print-fun #'print-arg))  
                      (print-space)  
                      (cond  
                        ((and highlight (funcall index-ok-p index highlight))  
                         (princ "===> ")  
                         (funcall print-fun arg)  
                         (princ " <==="))  
                        (t  
                         (funcall print-fun arg)))  
                      (incf index)))  
             (pprint-logical-block (nil nil :prefix "(" :suffix ")")  
               (when operator  
                 (print-with-highlight operator))  
               (mapc (lambda (arg)  
                       (print-with-highlight arg #'= #'princ))  
                     (arglist.provided-args arglist))  
               (mapc #'print-with-highlight  
                     (arglist.required-args arglist))  
               (when (arglist.optional-args arglist)  
                 (print-with-space '&optional)  
                 (mapc #'print-with-highlight  
                       (mapcar #'encode-optional-arg  
                               (arglist.optional-args arglist))))  
               (when (arglist.key-p arglist)  
                 (print-with-space '&key)  
                 (mapc #'print-keyword-arg-with-space  
                       (mapcar #'encode-keyword-arg  
                               (arglist.keyword-args arglist))))  
               (when (arglist.allow-other-keys-p arglist)  
                 (print-with-space '&allow-other-keys))  
               (cond ((not (arglist.rest arglist)))  
                     ((arglist.body-p arglist)  
                      (print-with-space '&body)  
                      (print-with-highlight (arglist.rest arglist) #'<=))  
                     (t  
                      (print-with-space '&rest)  
                      (print-with-highlight (arglist.rest arglist) #'<=)))  
               (mapc #'print-with-space  
                     (arglist.unknown-junk arglist)))))))))  
1548    
1549  (defslimefun variable-desc-for-echo-area (variable-name)  (defslimefun variable-desc-for-echo-area (variable-name)
1550    "Return a short description of VARIABLE-NAME, or NIL."    "Return a short description of VARIABLE-NAME, or NIL."
# Line 1530  If OPERATOR is non-nil, put it in front Line 1555  If OPERATOR is non-nil, put it in front
1555                  (*print-length* 10) (*print-circle* t))                  (*print-length* 10) (*print-circle* t))
1556               (format nil "~A => ~A" sym (symbol-value sym)))))))               (format nil "~A => ~A" sym (symbol-value sym)))))))
1557    
1558    (defun decode-required-arg (arg)
1559      "ARG can be a symbol or a destructuring pattern."
1560      (etypecase arg
1561        (symbol arg)
1562        (list   (decode-arglist arg))))
1563    
1564    (defun encode-required-arg (arg)
1565      (etypecase arg
1566        (symbol arg)
1567        (arglist (encode-arglist arg))))
1568    
1569  (defstruct (keyword-arg  (defstruct (keyword-arg
1570              (:conc-name keyword-arg.)              (:conc-name keyword-arg.)
1571              (:constructor make-keyword-arg (keyword arg-name default-arg)))              (:constructor make-keyword-arg (keyword arg-name default-arg)))
# Line 1547  Return three values: keyword, argument n Line 1583  Return three values: keyword, argument n
1583          ((and (consp arg)          ((and (consp arg)
1584                (consp (car arg)))                (consp (car arg)))
1585           (make-keyword-arg (caar arg)           (make-keyword-arg (caar arg)
1586                             (cadar arg)                             (decode-required-arg (cadar arg))
1587                             (cadr arg)))                             (cadr arg)))
1588          ((consp arg)          ((consp arg)
1589           (make-keyword-arg (intern (symbol-name (car arg)) keyword-package)           (make-keyword-arg (intern (symbol-name (car arg)) keyword-package)
# Line 1557  Return three values: keyword, argument n Line 1593  Return three values: keyword, argument n
1593           (error "Bad keyword item of formal argument list"))))           (error "Bad keyword item of formal argument list"))))
1594    
1595  (defun encode-keyword-arg (arg)  (defun encode-keyword-arg (arg)
1596    (if (eql (intern (symbol-name (keyword-arg.arg-name arg))    (cond
1597                     keyword-package)      ((arglist-p (keyword-arg.arg-name arg))
1598             (keyword-arg.keyword arg))       ;; Destructuring pattern
1599        (if (keyword-arg.default-arg arg)       (let ((keyword/name (list (keyword-arg.keyword arg)
1600            (list (keyword-arg.arg-name arg)                                 (encode-required-arg
1601                  (keyword-arg.default-arg arg))                                  (keyword-arg.arg-name arg)))))
1602            (keyword-arg.arg-name arg))         (if (keyword-arg.default-arg arg)
1603        (let ((keyword/name (list (keyword-arg.keyword arg)             (list keyword/name
1604                                  (keyword-arg.arg-name arg))))                   (keyword-arg.default-arg arg))
1605          (if (keyword-arg.default-arg arg)             (list keyword/name))))
1606              (list keyword/name      ((eql (intern (symbol-name (keyword-arg.arg-name arg))
1607                    (keyword-arg.default-arg arg))                    keyword-package)
1608              (list keyword/name)))))            (keyword-arg.keyword arg))
1609         (if (keyword-arg.default-arg arg)
1610             (list (keyword-arg.arg-name arg)
1611                   (keyword-arg.default-arg arg))
1612             (keyword-arg.arg-name arg)))
1613        (t
1614         (let ((keyword/name (list (keyword-arg.keyword arg)
1615                                   (keyword-arg.arg-name arg))))
1616           (if (keyword-arg.default-arg arg)
1617               (list keyword/name
1618                     (keyword-arg.default-arg arg))
1619               (list keyword/name))))))
1620    
1621  (progn  (progn
1622    (assert (equalp (decode-keyword-arg 'x)    (assert (equalp (decode-keyword-arg 'x)
# Line 1592  Return three values: keyword, argument n Line 1639  Return three values: keyword, argument n
1639  Return an OPTIONAL-ARG structure."  Return an OPTIONAL-ARG structure."
1640    (etypecase arg    (etypecase arg
1641      (symbol (make-optional-arg arg nil))      (symbol (make-optional-arg arg nil))
1642      (list   (make-optional-arg (car arg) (cadr arg)))))      (list   (make-optional-arg (decode-required-arg (car arg))
1643                                   (cadr arg)))))
1644    
1645  (defun encode-optional-arg (optional-arg)  (defun encode-optional-arg (optional-arg)
1646    (if (optional-arg.default-arg optional-arg)    (if (or (optional-arg.default-arg optional-arg)
1647        (list (optional-arg.arg-name optional-arg)            (arglist-p (optional-arg.arg-name optional-arg)))
1648          (list (encode-required-arg
1649                 (optional-arg.arg-name optional-arg))
1650              (optional-arg.default-arg optional-arg))              (optional-arg.default-arg optional-arg))
1651        (optional-arg.arg-name optional-arg)))        (optional-arg.arg-name optional-arg)))
1652    
# Line 1606  Return an OPTIONAL-ARG structure." Line 1656  Return an OPTIONAL-ARG structure."
1656    (assert (equalp (decode-optional-arg '(x t))    (assert (equalp (decode-optional-arg '(x t))
1657                    (make-optional-arg 'x t))))                    (make-optional-arg 'x t))))
1658    
 (defstruct (arglist (:conc-name arglist.))  
   provided-args         ; list of the provided actual arguments  
   required-args         ; list of the required arguments  
   optional-args         ; list of the optional arguments  
   key-p                 ; whether &key appeared  
   keyword-args          ; list of the keywords  
   rest                  ; name of the &rest or &body argument (if any)  
   body-p                ; whether the rest argument is a &body  
   allow-other-keys-p    ; whether &allow-other-keys appeared  
   aux-args              ; list of &aux variables  
   known-junk            ; &whole, &environment  
   unknown-junk)         ; unparsed stuff  
   
1659  (define-modify-macro nreversef () nreverse "Reverse the list in PLACE.")  (define-modify-macro nreversef () nreverse "Reverse the list in PLACE.")
1660    
1661  (defun decode-arglist (arglist)  (defun decode-arglist (arglist)
# Line 1661  Return an OPTIONAL-ARG structure." Line 1698  Return an OPTIONAL-ARG structure."
1698              (push (decode-optional-arg arg)              (push (decode-optional-arg arg)
1699                    (arglist.aux-args result)))                    (arglist.aux-args result)))
1700             ((nil)             ((nil)
1701              (push arg (arglist.required-args result)))              (push (decode-required-arg arg)
1702                      (arglist.required-args result)))
1703             ((&whole &environment)             ((&whole &environment)
1704              (setf mode nil)              (setf mode nil)
1705              (push arg (arglist.known-junk result)))))))              (push arg (arglist.known-junk result)))))))
# Line 1674  Return an OPTIONAL-ARG structure." Line 1712  Return an OPTIONAL-ARG structure."
1712      result))      result))
1713    
1714  (defun encode-arglist (decoded-arglist)  (defun encode-arglist (decoded-arglist)
1715    (append (arglist.required-args decoded-arglist)    (append (mapcar #'encode-required-arg (arglist.required-args decoded-arglist))
1716            (when (arglist.optional-args decoded-arglist)            (when (arglist.optional-args decoded-arglist)
1717              '(&optional))              '(&optional))
1718            (mapcar #'encode-optional-arg (arglist.optional-args decoded-arglist))            (mapcar #'encode-optional-arg (arglist.optional-args decoded-arglist))
# Line 1739  whether &allow-other-keys appears somewh Line 1777  whether &allow-other-keys appears somewh
1777        (let ((*package* package) (*print-case* :downcase)        (let ((*package* package) (*print-case* :downcase)
1778              (*print-pretty* t) (*print-circle* nil) (*print-readably* nil)              (*print-pretty* t) (*print-circle* nil) (*print-readably* nil)
1779              (*print-level* 10) (*print-length* 20))              (*print-level* 10) (*print-length* 20))
1780          (pprint-logical-block (nil nil :prefix prefix :suffix suffix)          (print-decoded-arglist-as-template decoded-arglist
1781            (print-decoded-arglist-as-template decoded-arglist))))))                                             :prefix prefix
1782                                               :suffix suffix)))))
1783  (defun print-decoded-arglist-as-template (decoded-arglist)  
1784    (let ((first-p t))  (defun print-decoded-arglist-as-template (decoded-arglist &key
1785      (flet ((space ()                                            (prefix "(") (suffix ")"))
1786               (unless first-p    (pprint-logical-block (nil nil :prefix prefix :suffix suffix)
1787                 (write-char #\space)      (let ((first-p t))
1788                 (pprint-newline :fill))        (flet ((space ()
1789               (setq first-p nil)))                 (unless first-p
1790        (dolist (arg (arglist.required-args decoded-arglist))                   (write-char #\space)
1791          (space)                   (pprint-newline :fill))
1792          (princ arg))                 (setq first-p nil))
1793        (dolist (arg (arglist.optional-args decoded-arglist))               (print-arg-or-pattern (arg)
1794          (space)                 (etypecase arg
1795          (format t "[~A]" (optional-arg.arg-name arg)))                   (symbol (princ arg))
1796        (dolist (keyword-arg (arglist.keyword-args decoded-arglist))                   (string (princ arg))
1797          (space)                   (list   (princ arg))
1798          (let ((arg-name (keyword-arg.arg-name keyword-arg))                   (arglist (print-decoded-arglist-as-template arg)))))
1799                (keyword (keyword-arg.keyword keyword-arg)))          (dolist (arg (arglist.required-args decoded-arglist))
1800            (format t "~W ~A"            (space)
1801                    (if (keywordp keyword) keyword `',keyword)            (print-arg-or-pattern arg))
1802                    arg-name)))          (dolist (arg (arglist.optional-args decoded-arglist))
1803        (when (and (arglist.rest decoded-arglist)            (space)
1804                   (or (not (arglist.keyword-args decoded-arglist))            (princ "[")
1805                       (arglist.allow-other-keys-p decoded-arglist)))            (print-arg-or-pattern (optional-arg.arg-name arg))
1806          (if (arglist.body-p decoded-arglist)            (princ "]"))
1807              (pprint-newline :mandatory)          (dolist (keyword-arg (arglist.keyword-args decoded-arglist))
1808              (space))            (space)
1809          (format t "~A..." (arglist.rest decoded-arglist)))))            (let ((arg-name (keyword-arg.arg-name keyword-arg))
1810    (pprint-newline :fill))                  (keyword (keyword-arg.keyword keyword-arg)))
1811                (format t "~W "
1812                        (if (keywordp keyword) keyword `',keyword))
1813                (print-arg-or-pattern arg-name)))
1814            (when (and (arglist.rest decoded-arglist)
1815                       (or (not (arglist.keyword-args decoded-arglist))
1816                           (arglist.allow-other-keys-p decoded-arglist)))
1817              (if (arglist.body-p decoded-arglist)
1818                  (pprint-newline :mandatory)
1819                  (space))
1820              (format t "~A..." (arglist.rest decoded-arglist)))))
1821        (pprint-newline :fill)))
1822    
1823  (defgeneric extra-keywords (operator &rest args)  (defgeneric extra-keywords (operator &rest args)
1824     (:documentation "Return a list of extra keywords of OPERATOR (a     (:documentation "Return a list of extra keywords of OPERATOR (a
# Line 1917  to determine the extra keywords.")) Line 1966  to determine the extra keywords."))
1966                  (cons (car args) determiners))                  (cons (car args) determiners))
1967          (call-next-method))))          (call-next-method))))
1968    
1969    (defun enrich-decoded-arglist-with-keywords (decoded-arglist keywords allow-other-keys-p)
1970      "Modify DECODED-ARGLIST using KEYWORDS and ALLOW-OTHER-KEYS-P."
1971      (when keywords
1972        (setf (arglist.key-p decoded-arglist) t)
1973        (setf (arglist.keyword-args decoded-arglist)
1974              (remove-duplicates
1975               (append (arglist.keyword-args decoded-arglist)
1976                       keywords)
1977               :key #'keyword-arg.keyword)))
1978      (setf (arglist.allow-other-keys-p decoded-arglist)
1979            (or (arglist.allow-other-keys-p decoded-arglist)
1980                allow-other-keys-p)))
1981    
1982  (defun enrich-decoded-arglist-with-extra-keywords (decoded-arglist form)  (defun enrich-decoded-arglist-with-extra-keywords (decoded-arglist form)
1983    "Determine extra keywords from the function call FORM, and modify    "Determine extra keywords from the function call FORM, and modify
1984  DECODED-ARGLIST to include them.  As a secondary return value, return  DECODED-ARGLIST to include them.  As a secondary return value, return
# Line 1926  was done." Line 1988  was done."
1988    (multiple-value-bind (extra-keywords extra-aok determining-args)    (multiple-value-bind (extra-keywords extra-aok determining-args)
1989        (apply #'extra-keywords form)        (apply #'extra-keywords form)
1990      ;; enrich the list of keywords with the extra keywords      ;; enrich the list of keywords with the extra keywords
1991      (when extra-keywords      (enrich-decoded-arglist-with-keywords decoded-arglist
1992        (setf (arglist.key-p decoded-arglist) t)                                            extra-keywords extra-aok)
       (setf (arglist.keyword-args decoded-arglist)  
             (remove-duplicates  
              (append (arglist.keyword-args decoded-arglist)  
                      extra-keywords)  
              :key #'keyword-arg.keyword)))  
     (setf (arglist.allow-other-keys-p decoded-arglist)  
           (or (arglist.allow-other-keys-p decoded-arglist) extra-aok))  
1993      (values decoded-arglist      (values decoded-arglist
1994              determining-args              determining-args
1995              (or extra-keywords extra-aok))))              (or extra-keywords extra-aok))))
1996    
1997    (defgeneric compute-enriched-decoded-arglist (operator-form argument-forms)
1998      (:documentation
1999       "Return three values: DECODED-ARGLIST, DETERMINING-ARGS, and
2000    ANY-ENRICHMENT, just like enrich-decoded-arglist-with-extra-keywords.
2001    If the arglist is not available, return :NOT-AVAILABLE."))
2002    
2003    (defmethod compute-enriched-decoded-arglist (operator-form argument-forms)
2004      (let ((arglist (arglist operator-form)))
2005        (etypecase arglist
2006          ((member :not-available)
2007           :not-available)
2008          (list
2009           (let ((decoded-arglist (decode-arglist arglist)))
2010             (enrich-decoded-arglist-with-extra-keywords decoded-arglist
2011                                                         (cons operator-form
2012                                                               argument-forms)))))))
2013    
2014    (defmethod compute-enriched-decoded-arglist ((operator-form (eql 'with-open-file))
2015                                                 argument-forms)
2016      (multiple-value-bind (decoded-arglist determining-args)
2017          (call-next-method)
2018        (let ((first-arg (first (arglist.required-args decoded-arglist)))
2019              (open-arglist (compute-enriched-decoded-arglist 'open nil)))
2020          (when (and (arglist-p first-arg) (arglist-p open-arglist))
2021            (enrich-decoded-arglist-with-keywords
2022             first-arg
2023             (arglist.keyword-args open-arglist)
2024             nil)))
2025        (values decoded-arglist determining-args t)))
2026    
2027  (defslimefun arglist-for-insertion (name)  (defslimefun arglist-for-insertion (name)
2028    (with-buffer-syntax ()    (with-buffer-syntax ()
2029      (let ((symbol (parse-symbol name)))      (let ((symbol (parse-symbol name)))
2030        (cond        (cond
2031          ((and symbol          ((and symbol
2032                (valid-operator-name-p name))                (valid-operator-name-p name))
2033           (let ((arglist (arglist symbol)))           (let ((decoded-arglist
2034             (etypecase arglist                  (compute-enriched-decoded-arglist symbol nil)))
2035               ((member :not-available)             (if (eql decoded-arglist :not-available)
2036                  :not-available)                 :not-available
2037               (list                 (decoded-arglist-to-template-string decoded-arglist
2038                (let ((decoded-arglist (decode-arglist arglist)))                                                     *buffer-package*))))
                 (enrich-decoded-arglist-with-extra-keywords decoded-arglist  
                                                             (list symbol))  
                 (decoded-arglist-to-template-string decoded-arglist  
                                                     *buffer-package*))))))  
2039          (t          (t
2040           :not-available)))))           :not-available)))))
2041    
# Line 1987  provided in ACTUAL-ARGLIST." Line 2068  provided in ACTUAL-ARGLIST."
2068  (defmethod form-completion (operator-form argument-forms &key (remove-args t))  (defmethod form-completion (operator-form argument-forms &key (remove-args t))
2069    (when (and (symbolp operator-form)    (when (and (symbolp operator-form)
2070               (valid-operator-symbol-p operator-form))               (valid-operator-symbol-p operator-form))
2071      (let ((arglist (arglist operator-form)))      (multiple-value-bind (decoded-arglist determining-args any-enrichment)
2072        (etypecase arglist          (compute-enriched-decoded-arglist operator-form argument-forms)
2073          (etypecase decoded-arglist
2074          ((member :not-available)          ((member :not-available)
2075           :not-available)           :not-available)
2076          (list          (arglist
2077           (let ((decoded-arglist (decode-arglist arglist)))           (cond
2078             (multiple-value-bind (decoded-arglist determining-args any-enrichment)             (remove-args
2079                 (enrich-decoded-arglist-with-extra-keywords decoded-arglist              ;; get rid of formal args already provided
2080                                                             (cons operator-form              (remove-actual-args decoded-arglist argument-forms))
2081                                                                   argument-forms))             (t
2082               (cond              ;; replace some formal args by determining actual args
2083                 (remove-args              (remove-actual-args decoded-arglist determining-args)
2084                  ;; get rid of formal args already provided              (setf (arglist.provided-args decoded-arglist)
2085                  (remove-actual-args decoded-arglist argument-forms))                    determining-args)))
2086                 (t           (return-from form-completion
2087                  ;; replace some formal args by determining actual args             (values decoded-arglist any-enrichment))))))
                 (remove-actual-args decoded-arglist determining-args)  
                 (setf (arglist.provided-args decoded-arglist)  
                       determining-args)))  
              (return-from form-completion  
                (values decoded-arglist any-enrichment))))))))  
2088    :not-available)    :not-available)
2089    
2090  (defmethod form-completion ((operator-form (eql 'defmethod))  (defmethod form-completion ((operator-form (eql 'defmethod))
# Line 2095  forward keywords to OPERATOR." Line 2172  forward keywords to OPERATOR."
2172         (arglist.keyword-args arglist)         (arglist.keyword-args arglist)
2173         (arglist.allow-other-keys-p arglist)))))         (arglist.allow-other-keys-p arglist)))))
2174    
2175  (defslimefun completions-for-keyword (name keyword-string)  (defun arglist-ref (decoded-arglist operator &rest indices)
2176    (with-buffer-syntax ()    (cond
2177      (let* ((form (operator-designator-to-form name))      ((null indices) decoded-arglist)
2178             (operator-form (first form))      ((not (arglist-p decoded-arglist)) nil)
2179             (argument-forms (rest form))      (t
2180             (arglist       (let ((index (first indices))
2181              (form-completion operator-form argument-forms             (args (append (and operator
2182                               :remove-args nil)))                                (list operator))
2183        (unless (eql arglist :not-available)                           (arglist.required-args decoded-arglist)
2184          (let* ((keywords                           (arglist.optional-args decoded-arglist))))
2185                  (mapcar #'keyword-arg.keyword         (when (< index (length args))
2186                          (arglist.keyword-args arglist)))           (let ((arg (elt args index)))
2187                 (keyword-name             (apply #'arglist-ref arg nil (rest indices))))))))
2188                  (tokenize-symbol keyword-string))  
2189                 (matching-keywords  (defslimefun completions-for-keyword (names keyword-string arg-indices)
2190                  (find-matching-symbols-in-list keyword-name keywords    (multiple-value-bind (name index)
2191                                                 #'compound-prefix-match))        (find-valid-operator-name names)
2192                 (converter (output-case-converter keyword-string))      (with-buffer-syntax ()
2193                 (strings        (let* ((form (operator-designator-to-form name))
2194                  (mapcar converter               (operator-form (first form))
2195                          (mapcar #'symbol-name matching-keywords)))               (argument-forms (rest form))
2196                 (completion-set               (arglist
2197                  (format-completion-set strings nil "")))                (form-completion operator-form argument-forms
2198            (list completion-set                                 :remove-args nil)))
2199                  (longest-completion completion-set)))))))          (unless (eql arglist :not-available)
2200              (let* ((indices (butlast (reverse (last arg-indices (1+ index)))))
2201                     (arglist (apply #'arglist-ref arglist operator-form indices)))
2202                (when (and arglist (arglist-p arglist))
2203                  ;; It would be possible to complete keywords only if we
2204                  ;; are in a keyword position, but it is not clear if we
2205                  ;; want that.
2206                  (let* ((keywords
2207                          (mapcar #'keyword-arg.keyword
2208                                  (arglist.keyword-args arglist)))
2209                         (keyword-name
2210                          (tokenize-symbol keyword-string))
2211                         (matching-keywords
2212                          (find-matching-symbols-in-list keyword-name keywords
2213                                                         #'compound-prefix-match))
2214                         (converter (output-case-converter keyword-string))
2215                         (strings
2216                          (mapcar converter
2217                                  (mapcar #'symbol-name matching-keywords)))
2218                         (completion-set
2219                          (format-completion-set strings nil "")))
2220                    (list completion-set
2221                          (longest-completion completion-set))))))))))
2222    
2223    
2224  (defun arglist-to-string (arglist package &key print-right-margin highlight)  (defun arglist-to-string (arglist package &key print-right-margin highlight)
# Line 2138  forward keywords to OPERATOR." Line 2237  forward keywords to OPERATOR."
2237    (assert (test-print-arglist '(&key (function #'+)) "(&key (function #'+))"))    (assert (test-print-arglist '(&key (function #'+)) "(&key (function #'+))"))
2238    (assert (test-print-arglist '(&whole x y z) "(y z)"))    (assert (test-print-arglist '(&whole x y z) "(y z)"))
2239    (assert (test-print-arglist '(x &aux y z) "(x)"))    (assert (test-print-arglist '(x &aux y z) "(x)"))
2240    (assert (test-print-arglist '(x &environment env y) "(x y)")))    (assert (test-print-arglist '(x &environment env y) "(x y)"))
2241  ;; Expected failure:    (assert (test-print-arglist '(&key ((function f))) "(&key ((function f)))")))
 ;; (assert (test-print-arglist '(&key ((function f))) "(&key ((function f)))"))  
2242    
2243    
2244  ;;;; Recording and accessing results of computations  ;;;; Recording and accessing results of computations

Legend:
Removed from v.1.386  
changed lines
  Added in v.1.387

  ViewVC Help
Powered by ViewVC 1.1.5