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

Diff of /slime/swank-ecl.lisp

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

revision 1.31 by trittweiler, Thu Sep 18 10:08:34 2008 UTC revision 1.32 by trittweiler, Fri Sep 26 23:14:10 2008 UTC
# Line 170  Line 170 
170    
171  ;;;; Documentation  ;;;; Documentation
172    
173    (defun grovel-docstring-for-arglist (name type)
174      (flet ((compute-arglist-offset (docstring)
175               (when docstring
176                 (let ((pos1 (search "Args: " docstring)))
177                   (if pos1
178                       (+ pos1 6)
179                       (let ((pos2 (search "Syntax: " docstring)))
180                         (when pos2
181                           (+ pos2 8))))))))
182        (let* ((docstring (si::get-documentation name type))
183               (pos (compute-arglist-offset docstring)))
184          (if pos
185              (multiple-value-bind (arglist errorp)
186                  (ignore-errors
187                    (values (read-from-string docstring t nil :start pos)))
188                (if errorp :not-available (cdr arglist)))
189              :not-available ))))
190    
191  (defimplementation arglist (name)  (defimplementation arglist (name)
192    (or (functionp name) (setf name (symbol-function name)))    (cond ((special-operator-p name)
193    (if (functionp name)           (grovel-docstring-for-arglist name 'function))
194        (typecase name          ((macro-function name)
195          (generic-function           (grovel-docstring-for-arglist name 'function))
196           (clos::generic-function-lambda-list name))          ((or (functionp name) (fboundp name))
197          (compiled-function           (multiple-value-bind (name fndef)
198           ; most of the compiled functions have an Args: line in their docs               (if (functionp name)
199           (with-input-from-string (s (or                   (values (function-name name) name)
200                                       (si::get-documentation                   (values name (fdefinition name)))
201                                        (si:compiled-function-name name) 'function)             (typecase fndef
202                                       ""))               (generic-function
203             (do ((line (read-line s nil) (read-line s nil)))                (clos::generic-function-lambda-list fndef))
204                 ((not line) :not-available)               (compiled-function
205               (ignore-errors                (grovel-docstring-for-arglist name 'function))
206                 (if (string= (subseq line 0 6) "Args: ")               (function
207                     (return-from nil                (let ((fle (function-lambda-expression fndef)))
208                       (read-from-string (subseq line 6))))))))                  (case (car fle)
209           ;                    (si:lambda-block (caddr fle))
210          (function                    (t               :not-available)))))))
211           (let ((fle (function-lambda-expression name)))          (t :not-available)))
            (case (car fle)  
              (si:lambda-block (caddr fle))  
              (t               :not-available)))))  
       :not-available))  
212    
213  (defimplementation function-name (f)  (defimplementation function-name (f)
214    (si:compiled-function-name f))    (si:compiled-function-name f))

Legend:
Removed from v.1.31  
changed lines
  Added in v.1.32

  ViewVC Help
Powered by ViewVC 1.1.5