Paul Sexton committed 610e73c

Fixes to 'function-lambda-list' (thanks to Christian Nybø).

Comments (0)

Files changed (1)

   semicolons are removed and the rest of the line is syntax highlighted.
 * Combining org mode and common lisp mode in a single Emacs buffer
 You can use org mode markup within docstrings, but you can't see the effects of
 the markup until you export the documentation to org using CLOD. You also don't
 get access to org's support for automatic formatting of bulleted lists as you
    the mmm-mode directory to the directory where you installed mmm-mode.
 3. Restart emacs. Load a lisp source file. All documentation strings should
    appear with a coloured background, and when you move the cursor inside them,
-   you will see 'Lisp[Org]' on the modeline. 
+   you will see 'Lisp[Org]' on the modeline.
 4. If not everything is highlighting correctly, or if you write a new docstring
    and org does not activate within it, press control-` to 'refresh' mmm-mode.
 1. Any string that emacs fontifies using 'font-lock-doc-face'. (in other words,
    font-lock mode must be active.)
 2. Any string inside the form '=(:documentation STRING)='.
-3. Finally, any string whose first three characters are '###'. Since lines 
+3. Finally, any string whose first three characters are '###'. Since lines
    beginning with a hash are interpreted as comments by org mode, these
    characters will disappear when you export your document to HTML or other
 : A string, or nil.
 : * Description
 : Produce documentation for the package =PKG=.
 : The documentation's destination depends on the value of =FILE/STREAM=:
 : - =STRING=: documentation is written to the file named by the string.
 : - =STREAM=: documentation is written to the already existing stream.
 : - =NIL=: documentation is written to a string, which is then returned by
 :   this function.
 : Explanation of optional arguments:
 : - =TITLE=, =AUTHOR= and =EMAIL= specify the document title, the name of
 :   the author, and the email address of the author.
 : ;;; (clod:document-package :mypkg \"\"
 : ;;;      :style-sheet \"swiss.css\" :title \"My Package\"
 : ;;;      :author \"F. B. Quux\" :email \"\")
 : * See also
 : - [[document-packages]]
     ((and (functionp func)
           (typep func (find-class 'generic-function)))
      (values (generic-function-lambda-list func) t))
-    ((and (fboundp func)
-          (typep (symbol-function func) (find-class 'generic-function)))
+    ((and
+      (or (symbolp func)                ;fboundp takes either symbol
+          (and (consp func)             ;or (setf symbol)
+               (not (null cdr func)) (null (cddr func))
+               (eq (first func) 'setf) (symbolp (second func))))
+      (fboundp func)
+      (typep (symbol-function func) (find-class 'generic-function)))
      (values (generic-function-lambda-list (symbol-function func)) t))
      (let ((arglist (lw:function-lambda-list func)))
        (etypecase arglist
-         ((member :dont-know) 
+         ((member :dont-know)
           (values nil nil))
-          (values (replace-strings-with-symbols arglist)) t)))
+          (values (replace-strings-with-symbols arglist) t))))
      (multiple-value-bind (arglist binding) (let ((*break-on-signals* nil))
                                               (ccl:arglist func))
            (values nil nil)))
      (cond ((symbolp func)
-            (multiple-value-bind (arglist present) 
+            (multiple-value-bind (arglist present)
                 (sys::arglist func)
               (when (and (not present)
                          (fboundp func)
                  (values nil nil))))))))
      (let ((llist
-            (etypecase func
-              (function (cmucl-function-arglist fun))
-              (symbol (cmucl-function-arglist (or (macro-function func)
-                                                  (symbol-function func)))))))
+             (etypecase func
+               (function (cmucl-function-arglist fun))
+               (symbol (cmucl-function-arglist (or (macro-function func)
+                                                   (symbol-function func)))))))
        (if (eql llist :not-available)
            (values nil nil)
            (values llist t)))
      (block nil
        (or (ignore-errors
-             (return (values (ext:arglist func) t)))
+            (return (values (ext:arglist func) t)))
-             (let ((exp (function-lambda-expression func)))
-               (and exp (return (values (second exp) t)))))
+            (let ((exp (function-lambda-expression func)))
+              (and exp (return (values (second exp) t)))))
            (values nil nil))))))
                   (error () :not-available)))
                ;; this should work both for compiled-debug-function
                ;; and for interpreted-debug-function
-               (t 
-                (handler-case (debug-function-arglist 
+               (t
+                (handler-case (debug-function-arglist
                                (di::function-debug-function fun))
                   (di:unhandled-condition () :not-available))))))
     (check-type arglist (or list (member :not-available)))
 (defun cmucl-read-arglist (fn)
   "Parse the arglist-string of the function object FN."
-  (let ((string (kernel:%function-arglist 
+  (let ((string (kernel:%function-arglist
                  (kernel:%function-self fn)))
         (package (find-pkg
   ;; byte-code functions.  Use the arg-count and return something like
   ;; (arg0 arg1 ...)
   (etypecase fn
-    (c::simple-byte-function 
+    (c::simple-byte-function
      (loop for i from 0 below (c::simple-byte-function-num-args fn)
            collect (cmucl-make-arg-symbol i)))
-    (c::hairy-byte-function 
+    (c::hairy-byte-function
      (cmucl-hairy-byte-function-arglist fn))
      (cmucl-byte-code-function-arglist (c::byte-closure-function fn)))))
 ;;     "Alist of =(REGEX . REPLACEMENT)= cons pairs. Used to ensure that symbols
 ;; do not contain any characters which org will misinterpret as formatting
 ;; directives.
 ;; See also: [[org-safe-symbol]]."))
 See also: [[html-safe-string]].
 (defun html-safe-string (str)
   "* Arguments
                    (collect (format nil "..~2X.." (char-code c)))
                    (collect (make-string 1 :initial-element c)))))))))
 ;;;; Formatting  ==============================================================
   (wrap-and-write (list->string-with-commas ls)))
 (defun write-docstring-section (title docstr)
   "Writes the documentation string DOCSTR within its own subsection."
     (write-indented (2)
       (dolist (line (cdr lines))
         (write-out "~A~%" line)))))
 (defun write-index (pkg &optional (accessibilities (list :internal :external)))
     (writing-section ("Index")
-      (wrap-and-write 
+      (wrap-and-write
        (format nil
                "~%~{~A  ~}~%"
     (write-docstring-section "Description" (documentation sym 'function))))
 (defmethod document ((sym symbol) (doctype (eql :macro)))
   (writing-section-for-symbol (:macro sym)
     ;; The same goes for macros.
                   (if (method-qualifiers m)
                       (format nil "~{ ~S~}" (method-qualifiers m))
-                  (make-specialised-lambda-list 
+                  (make-specialised-lambda-list
                    (method-lambda-list m)
                    (method-specializers m)))))
                   (documentation m t))
              (write-docstring-section "Description"
                                       (documentation m t))))))))
 ;;    (if (method-qualifiers m)
 ;;        (format nil "~{ ~S~}" (method-qualifiers m))
 ;;        "")
-;;    (make-specialised-lambda-list 
+;;    (make-specialised-lambda-list
 ;;     (method-lambda-list m)
 ;;     (method-specializers m)))
 ;;   (if (and (slot-exists-p m 'documentation)
                         (class-direct-superclasses c))))
               (list "None."))))
           (write-bullet-point "Precedence list:")
-          (write-indented (4)                
+          (write-indented (4)
               (mapcar #'make-class-link
                         (class-precedence-list c))))
               (list "None."))))
           (write-bullet-point "Direct subclasses:")
-          (write-indented (4)                
+          (write-indented (4)
-             (or 
+             (or
               (mapcar #'make-class-link
              (documentation slot t))
         (write-docstring-section "Description" (documentation slot t)))
 (defmethod document ((slot effective-slot-definition)
                      (doctype (eql :slot)))
   (unless title
     (setf title (format nil "The ~A package"
                         (package-name pkg))))
-  (document-packages (list pkg) file/stream 
+  (document-packages (list pkg) file/stream
                      :auto-links auto-links
                      :lines-between-sections lines-between-sections
                      :brief-methods brief-methods
                      :class-diagram class-diagram
                      :style-sheet style-sheet
                      :title title :author author :email email))