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

Diff of /slime/swank.lisp

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

revision 1.318 by mkoeppe, Thu Aug 4 20:16:45 2005 UTC revision 1.319 by mkoeppe, Sat Aug 6 14:50:20 2005 UTC
# Line 1614  provided in ACTUAL-ARGLIST." Line 1614  provided in ACTUAL-ARGLIST."
1614                           (arglist.keyword-args decoded-arglist)                           (arglist.keyword-args decoded-arglist)
1615                           :key #'keyword-arg.keyword))))                           :key #'keyword-arg.keyword))))
1616    
1617    (defgeneric form-completion (operator-form &rest argument-forms))
1618    
1619    (defmethod form-completion (operator-form &rest argument-forms)
1620      (when (and (symbolp operator-form)
1621                 (valid-operator-symbol-p operator-form))
1622        (let ((arglist (arglist operator-form)))
1623          (etypecase arglist
1624            ((member :not-available)
1625             :not-available)
1626            (list
1627             (let ((decoded-arglist (decode-arglist arglist)))
1628               (enrich-decoded-arglist-with-extra-keywords decoded-arglist
1629                                                           (cons operator-form
1630                                                                 argument-forms))
1631               ;; get rid of formal args already provided
1632               (remove-actual-args decoded-arglist argument-forms)
1633               (return-from form-completion decoded-arglist))))))
1634      :not-available)
1635    
1636    (defmethod form-completion ((operator-form (eql 'defmethod))
1637                                &rest argument-forms)
1638      (when (and (listp argument-forms)
1639                 (not (null argument-forms)) ;have generic function name
1640                 (notany #'listp (rest argument-forms))) ;don't have arglist yet
1641        (let* ((gf-name (first argument-forms))
1642               (gf (and (or (symbolp gf-name)
1643                            (and (listp gf-name)
1644                                 (eql (first gf-name) 'setf)))
1645                        (fboundp gf-name)
1646                        (fdefinition gf-name))))
1647          (when (typep gf 'generic-function)
1648            (let ((arglist (arglist gf)))
1649              (etypecase arglist
1650                ((member :not-available))
1651                (list
1652                 (return-from form-completion
1653                   (make-arglist :required-args (list arglist)
1654                                 :rest "body" :body-p t))))))))
1655      (call-next-method))
1656    
1657  (defslimefun complete-form (form-string)  (defslimefun complete-form (form-string)
1658    "Read FORM-STRING in the current buffer package, then complete it    "Read FORM-STRING in the current buffer package, then complete it
1659  by adding a template for the missing arguments."  by adding a template for the missing arguments."
# Line 1623  by adding a template for the missing arg Line 1663  by adding a template for the missing arg
1663            (when (consp form)            (when (consp form)
1664              (let ((operator-form (first form))              (let ((operator-form (first form))
1665                    (argument-forms (rest form)))                    (argument-forms (rest form)))
1666                (when (and (symbolp operator-form)                (let ((form-completion
1667                           (valid-operator-symbol-p operator-form))                       (apply #'form-completion operator-form argument-forms)))
1668                  (let ((arglist (arglist operator-form)))                  (unless (eql form-completion :not-available)
1669                    (etypecase arglist                    (return-from complete-form
1670                      ((member :not-available)                      (decoded-arglist-to-template-string form-completion
1671                       :not-available)                                                          *buffer-package*
1672                      (list                                                          :prefix ""))))))
                      (let ((decoded-arglist (decode-arglist arglist)))  
                        (enrich-decoded-arglist-with-extra-keywords decoded-arglist form)  
                        ;; get rid of formal args already provided  
                        (remove-actual-args decoded-arglist argument-forms)  
                        (return-from complete-form  
                          (decoded-arglist-to-template-string decoded-arglist  
                                                              *buffer-package*  
                                                              :prefix "")))))))))  
1673            :not-available)            :not-available)
1674        (reader-error (c)        (reader-error (c)
1675          (declare (ignore c))          (declare (ignore c))

Legend:
Removed from v.1.318  
changed lines
  Added in v.1.319

  ViewVC Help
Powered by ViewVC 1.1.5