(and symbol
(eql (symbol-package symbol) *package*)
(or (ignore-errors (find-class symbol))
- (boundp symbol) (fboundp symbol))))
+ (boundp symbol) (fboundp symbol))))
(defun linkable-symbol-p (word)
(labels ((symbol-char (c) (or (upper-case-p c) (digit-char-p c)
- (eql c #\-))))
+ (eql c #\-))))
(and (every #'symbol-char word)
- (some #'upper-case-p word)
- (worth-documenting-p (find-symbol word)))))
+ (some #'upper-case-p word)
+ (worth-documenting-p (find-symbol word)))))
(defun markup-word (w)
(if (symbolp w) (setf w (princ-to-string w)))
- (cond ((linkable-symbol-p w)
- (format nil "<a href=\"#~A\">~A</a>"
- w w))
- ((and (> (length w) 0)
- (eql (elt w 0) #\_)
- (eql (elt w (1- (length w))) #\_))
- (format nil "<b>~A</b>" (subseq w 1 (1- (length w)))))
- (t w)))
+ (cond ((linkable-symbol-p w)
+ (format nil "<a href=\"#~A\">~A</a>"
+ w w))
+ ((and (> (length w) 0)
+ (eql (elt w 0) #\_)
+ (eql (elt w (1- (length w))) #\_))
+ (format nil "<b>~A</b>" (subseq w 1 (1- (length w)))))
+ (t w)))
(defun markup-space (w)
(let ((para (search (coerce '(#\Newline #\Newline) 'string) w)))
(if para
- (format nil "~A<P>~A"
- (subseq w 0 (1+ para))
- (markup-space (subseq w (1+ para) nil)))
- w)))
+ (format nil "~A<P>~A"
+ (subseq w 0 (1+ para))
+ (markup-space (subseq w (1+ para) nil)))
+ w)))
(defun text-markup (text)
(let ((start-word 0) (end-word 0))
(labels ((read-word ()
- (setf end-word
- (position-if
- (lambda (x) (member x '(#\Space #\, #\. #\Newline)))
- text :start start-word))
- (subseq text start-word end-word))
- (read-space ()
- (setf start-word
- (position-if-not
- (lambda (x) (member x '(#\Space #\, #\. #\Newline)))
- text :start end-word ))
- (subseq text end-word start-word)))
+ (setf end-word
+ (position-if
+ (lambda (x) (member x '(#\Space #\, #\. #\Newline)))
+ text :start start-word))
+ (subseq text start-word end-word))
+ (read-space ()
+ (setf start-word
+ (position-if-not
+ (lambda (x) (member x '(#\Space #\, #\. #\Newline)))
+ text :start end-word ))
+ (subseq text end-word start-word)))
(with-output-to-string (o)
- (loop for inword = (read-word)
- do (princ (markup-word inword) o)
- while (and start-word end-word)
- do (princ (markup-space (read-space)) o)
- while (and start-word end-word))))))
+ (loop for inword = (read-word)
+ do (princ (markup-word inword) o)
+ while (and start-word end-word)
+ do (princ (markup-space (read-space)) o)
+ while (and start-word end-word))))))
(defun do-defpackage (form stream)
(when (string-equal name (package-name *package*))
(format stream "<h1>Package ~A</h1>~%" name)
(when (documentation *package* t)
- (princ (text-markup (documentation *package* t))))
+ (princ (text-markup (documentation *package* t))))
(let ((exports (assoc :export options)))
(when exports
(setf *symbols* (mapcar #'symbol-name (cdr exports)))))
(destructuring-bind (defn name super slots &rest options) form
(when (interesting-name-p name)
(let ((class (find-class name)))
- (format stream "<p><a name=\"~A\"><i>Class: </i><b>~A</b></a>~%"
- name name)
- #+nil (format stream "<p><b>Superclasses: </b> ~{~A ~}~%"
- (mapcar (lambda (x) (text-markup (class-name x)))
- (mop:class-direct-superclasses class)))
- (if (documentation class 'type)
- (format stream "<blockquote>~A</blockquote>~%"
- (text-markup (documentation class 'type))))
- (when slots
- (princ "<p><b>Slots:</b><ul>" stream)
- (dolist (slot slots)
- (destructuring-bind
- (name &key reader writer accessor initarg initform type
- documentation)
- (if (consp slot) slot (list slot))
- (format stream "<li>~A : ~A</li>~%" name
- (if documentation (text-markup documentation) ""))))
- (princ "</ul>" stream))
- t))))
-
+ (format stream "<p><a name=\"~A\"><i>Class: </i><b>~A</b></a>~%"
+ name name)
+ #+nil (format stream "<p><b>Superclasses: </b> ~{~A ~}~%"
+ (mapcar (lambda (x) (text-markup (class-name x)))
+ (mop:class-direct-superclasses class)))
+ (if (documentation class 'type)
+ (format stream "<blockquote>~A</blockquote>~%"
+ (text-markup (documentation class 'type))))
+ (when slots
+ (princ "<p><b>Slots:</b><ul>" stream)
+ (dolist (slot slots)
+ (destructuring-bind
+ (name &key reader writer accessor initarg initform type
+ documentation)
+ (if (consp slot) slot (list slot))
+ (format stream "<li>~A : ~A</li>~%" name
+ (if documentation (text-markup documentation) ""))))
+ (princ "</ul>" stream))
+ t))))
+
(defun interesting-name-p (name)
(cond ((consp name)
- (and (eql (car name) 'setf)
- (interesting-name-p (cadr name))))
- (t (member (symbol-name name) *symbols* :test #'string=))))
+ (and (eql (car name) 'setf)
+ (interesting-name-p (cadr name))))
+ (t (member (symbol-name name) *symbols* :test #'string=))))
(defun markup-lambdalist (l)
(let (key-p)
(loop for i in l
- if (eq '&key i) do (setf key-p t)
- end
- if (and (not key-p) (consp i))
- collect (list (car i) (markup-word (cadr i)))
- else collect i)))
+ if (eq '&key i) do (setf key-p t)
+ end
+ if (and (not key-p) (consp i))
+ collect (list (car i) (markup-word (cadr i)))
+ else collect i)))
(defun do-defunlike (form label stream)
(destructuring-bind (defn name lambdalist &optional doc &rest code) form
(when (interesting-name-p name)
(when (symbolp name)
- (setf *symbols* (remove (symbol-name name) *symbols* :test #'string=)))
+ (setf *symbols* (remove (symbol-name name) *symbols* :test #'string=)))
(format stream "<p><a name=\"~A\"><table width=\"100%\"><tr><td width=\"80%\">(~A <i>~A</i>)</td><td align=right>~A</td></tr></table>~%"
name (string-downcase (princ-to-string name))
- (string-downcase
- (format nil "~{ ~A~}" (markup-lambdalist lambdalist)))
- label)
+ (string-downcase
+ (format nil "~{ ~A~}" (markup-lambdalist lambdalist)))
+ label)
(if (stringp doc)
(format stream "<blockquote>~A</blockquote>~%"
- (text-markup doc)))
+ (text-markup doc)))
t)))
(defun do-defun (form stream) (do-defunlike form "Function" stream))
(pushnew (symbol-name lisp-name) *symbols*)
(do-defunlike `(defun ,lisp-name ((socket socket) argument)
- ,(format nil "Return the value of the ~A socket option for SOCKET. This can also be updated with SETF." (symbol-name c-name) ) 'empty)
+ ,(format nil "Return the value of the ~A socket option for SOCKET. This can also be updated with SETF." (symbol-name c-name) ) 'empty)
"Accessor" stream)))
-
+
(defun do-form (form output-stream)
(cond ((not (listp form)) nil)
- ((string= (symbol-name (car form)) "DEFINE-SOCKET-OPTION-BOOL")
- (do-boolean-sockopt form output-stream))
- ((eq (car form) 'defclass)
- (do-defclass form output-stream))
- ((eq (car form) 'eval-when)
- (do-form (third form) output-stream))
- ((eq (car form) 'defpackage)
- (do-defpackage form output-stream))
- ((eq (car form) 'defun)
- (do-defun form output-stream))
- ((eq (car form) 'defmethod)
- (do-defmethod form output-stream))
- ((eq (car form) 'defgeneric)
- (do-defgeneric form output-stream))
- (t nil)))
+ ((string= (symbol-name (car form)) "DEFINE-SOCKET-OPTION-BOOL")
+ (do-boolean-sockopt form output-stream))
+ ((eq (car form) 'defclass)
+ (do-defclass form output-stream))
+ ((eq (car form) 'eval-when)
+ (do-form (third form) output-stream))
+ ((eq (car form) 'defpackage)
+ (do-defpackage form output-stream))
+ ((eq (car form) 'defun)
+ (do-defun form output-stream))
+ ((eq (car form) 'defmethod)
+ (do-defmethod form output-stream))
+ ((eq (car form) 'defgeneric)
+ (do-defgeneric form output-stream))
+ (t nil)))
(defun do-file (input-stream output-stream)
"Read in a Lisp program on INPUT-STREAM and make semi-pretty HTML on OUTPUT-STREAM"
(let ((eof-marker (gensym)))
- (if (< 0
- (loop for form = (read input-stream nil eof-marker)
- until (eq form eof-marker)
- if (do-form form output-stream)
- count 1 #| and
- do (princ "<hr width=\"20%\">" output-stream) |# ))
- (format output-stream "<hr>"
- ))))
+ (if (< 0
+ (loop for form = (read input-stream nil eof-marker)
+ until (eq form eof-marker)
+ if (do-form form output-stream)
+ count 1 #| and
+ do (princ "<hr width=\"20%\">" output-stream) |# ))
+ (format output-stream "<hr>"
+ ))))
(defvar *standard-sharpsign-reader*
(get-dispatch-macro-character #\# #\|))
"Produce HTML documentation for all files defined in SYSTEM, covering
symbols exported from PACKAGE"
(let ((*package* (find-package package))
- (*readtable* (copy-readtable))
- (*standard-output* output-stream))
+ (*readtable* (copy-readtable))
+ (*standard-output* output-stream))
(set-dispatch-macro-character
#\# #\|
(lambda (s c n)
(if (eql (peek-char nil s t nil t) #\|)
- (princ
- (text-markup
- (coerce
- (loop with discard = (read-char s t nil t)
- ;initially (princ "<P>")
- for c = (read-char s t nil t)
- until (and (eql c #\|)
- (eql (peek-char nil s t nil t) #\#))
- collect c
- finally (read-char s t nil t))
- 'string)))
- (funcall *standard-sharpsign-reader* s c n))))
+ (princ
+ (text-markup
+ (coerce
+ (loop with discard = (read-char s t nil t)
+ ;initially (princ "<P>")
+ for c = (read-char s t nil t)
+ until (and (eql c #\|)
+ (eql (peek-char nil s t nil t) #\#))
+ collect c
+ finally (read-char s t nil t))
+ 'string)))
+ (funcall *standard-sharpsign-reader* s c n))))
(dolist (c (cclan:all-components 'sb-bsd-sockets))
(when (and (typep c 'cl-source-file)
- (not (typep c 'sb-bsd-sockets-system::constants-file)))
- (with-open-file (in (component-pathname c) :direction :input)
- (do-file in *standard-output*))))))
+ (not (typep c 'sb-bsd-sockets-system::constants-file)))
+ (with-open-file (in (component-pathname c) :direction :input)
+ (do-file in *standard-output*))))))
(defun start ()
(with-open-file (*standard-output* "index.html" :direction :output)
projects / sbcl.git / blobdiff