annotation-plist.lisp

   1 ;;; -*- lisp -*-
   2
   3 ;;;; This software was originally part of the SBCL software system.
   4 ;;;; SBCL is in the public domain and is provided with absolutely no warranty.
   5 ;;;; See the COPYING file for more information.
   6 ;;;;
   7 ;;;; Written by Rudi Schlatte <rudi@constantly.at>, mangled
   8 ;;;; by Nikodemus Siivola, Luis Oliveira, David Lichteblau, and others.
   9
  10 (in-package :parse-docstrings)
  11
  12
  13 ;;;; Fetching annotations that were stored using ANNOTATION-DOCUMENTATION:
  14
  15 (defun raw-annotations (name doc-type)
  16   (let ((key :documentation-annotations))
  17     (when (and (consp name) (eq (car name) 'setf))
  18       (setf name (second name))
  19       (setf key :setf-documentation-annotations))
  20     (getf (get name key) doc-type)))
  21
  22 (defun destructure-raw-annotation (x)
  23   (let* ((kind (car x))
  24          (sym nil)
  25          (docstring
  26           (with-output-to-string (s)
  27             (dolist (y (cdr x))
  28               (etypecase y
  29                 (string
  30                  (fresh-line s)
  31                  (write-string y s))
  32                 (symbol
  33                  (setf sym y))
  34                 (t
  35                  (warn "ignoring unrecognized sub-annotation: ~A" y)))))))
  36     (values kind sym docstring)))
  37
  38 (defun parse-raw-annotations (annotations)
  39   (let ((d-a (make-instance 'documentation-annotations)))
  40     (with-slots (arguments
  41                  return-values
  42                  conditions
  43                  slot-accessors
  44                  constructors
  45                  see-also-list)
  46         d-a
  47       (let ((docstring
  48              (with-output-to-string (s)
  49                (dolist (x annotations)
  50                  (typecase x
  51                    (string
  52                     (fresh-line s)
  53                     (write-string x s))
  54                    (list
  55                     (multiple-value-bind (kind sym docstring)
  56                         (destructure-raw-annotation x)
  57                       (ecase kind
  58                         (:argument
  59                          (push (make-instance 'parameter-like-annotation
  60                                               :name sym
  61                                               :docstring docstring)
  62                                arguments))
  63                         (:return-value
  64                          (push (make-instance 'parameter-like-annotation
  65                                               :name sym
  66                                               :docstring docstring)
  67                                return-values))
  68                         (:condition
  69                          (push (make-instance 'cross-reference-annotation
  70                                               :target sym
  71                                               :doc-type 'type)
  72                                conditions))
  73                         (:slot-accessor
  74                          (push (make-instance 'cross-reference-annotation
  75                                               :target sym
  76                                               :doc-type 'function)
  77                                slot-accessors))
  78                         (:constructor
  79                          (push (make-instance 'cross-reference-annotation
  80                                               :target sym
  81                                               :doc-type 'function)
  82                                constructors))
  83                         (:see-also-function
  84                          (push (make-instance 'cross-reference-annotation
  85                                               :target sym
  86                                               :doc-type 'function)
  87                                see-also-list))
  88                         (:see-also-variable
  89                          (push (make-instance 'cross-reference-annotation
  90                                               :target sym
  91                                               :doc-type 'variable)
  92                                see-also-list))
  93                         (:see-also-type
  94                          (push (make-instance 'cross-reference-annotation
  95                                               :target sym
  96                                               :doc-type 'type)
  97                                see-also-list)))))
  98                    (t
  99                     (warn "ignoring unrecognized annotation: ~A" x)))))))
 100         (setf arguments (nreverse arguments))
 101         (setf return-values (nreverse return-values))
 102         (setf conditions (nreverse conditions))
 103         (setf slot-accessors (nreverse slot-accessors))
 104         (setf constructors (nreverse constructors))
 105         (setf see-also-list (nreverse see-also-list))
 106         (values docstring d-a)))))
 107
 108 (defun annotations (name doc-type)
 109   (parse-raw-annotations (raw-annotations name doc-type)))