X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-bsd-sockets%2Fdoc.lisp;h=534d61d14aabc037f5ae3a174bda5c7cd4c3d596;hb=10cdee0326e9e8a5bbfe1d8312a73d58f023fb5f;hp=fa7a4825646e5e6765ba2980bd271f6326f7d893;hpb=335ea712981366d406c7909beb39251ec0922369;p=sbcl.git diff --git a/contrib/sb-bsd-sockets/doc.lisp b/contrib/sb-bsd-sockets/doc.lisp index fa7a482..534d61d 100644 --- a/contrib/sb-bsd-sockets/doc.lisp +++ b/contrib/sb-bsd-sockets/doc.lisp @@ -1,3 +1,8 @@ +;;;; the old documentation extracted / generator for db-sockets / sb-bsd-sockets +;;;; +;;;; Not used anymore as the documentation is now integrated into the user manual, +;;;; but I didn't have heart yet to delete this. -- NS 20040801 + (eval-when (:load-toplevel :compile-toplevel :execute) (defpackage :db-doc (:use :cl :asdf #+sbcl :sb-ext #+cmu :ext ))) (in-package :db-doc) @@ -26,53 +31,53 @@ do cross-references and stuff (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" - w w)) - ((and (> (length w) 0) - (eql (elt w 0) #\_) - (eql (elt w (1- (length w))) #\_)) - (format nil "~A" (subseq w 1 (1- (length w))))) - (t w))) + (cond ((linkable-symbol-p w) + (format nil "~A" + w w)) + ((and (> (length w) 0) + (eql (elt w 0) #\_) + (eql (elt w (1- (length w))) #\_)) + (format nil "~A" (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

~A" - (subseq w 0 (1+ para)) - (markup-space (subseq w (1+ para) nil))) - w))) + (format nil "~A

~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) @@ -81,7 +86,7 @@ do cross-references and stuff (when (string-equal name (package-name *package*)) (format stream "

Package ~A

~%" 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))))) @@ -91,55 +96,55 @@ do cross-references and stuff (destructuring-bind (defn name super slots &rest options) form (when (interesting-name-p name) (let ((class (find-class name))) - (format stream "

Class: ~A~%" - name name) - #+nil (format stream "

Superclasses: ~{~A ~}~%" - (mapcar (lambda (x) (text-markup (class-name x))) - (mop:class-direct-superclasses class))) - (if (documentation class 'type) - (format stream "

~A
~%" - (text-markup (documentation class 'type)))) - (when slots - (princ "

Slots:

" stream)) - t)))) - + (format stream "

Class: ~A~%" + name name) + #+nil (format stream "

Superclasses: ~{~A ~}~%" + (mapcar (lambda (x) (text-markup (class-name x))) + (mop:class-direct-superclasses class))) + (if (documentation class 'type) + (format stream "

~A
~%" + (text-markup (documentation class 'type)))) + (when slots + (princ "

Slots:

" 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 "

(~A ~A)~A
~%" 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 "

~A
~%" - (text-markup doc))) + (text-markup doc))) t))) (defun do-defun (form stream) (do-defunlike form "Function" stream)) @@ -150,38 +155,38 @@ do cross-references and stuff (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 "
" output-stream) |# )) - (format output-stream "
" - )))) + (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 "
" output-stream) |# )) + (format output-stream "
" + )))) (defvar *standard-sharpsign-reader* (get-dispatch-macro-character #\# #\|)) @@ -192,34 +197,40 @@ do cross-references and stuff "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 "

") - 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 "

") + 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) (format t "SBCL BSD-Sockets API Reference~%") - (asdf:operate 'asdf:load-op 'sb-bsd-sockets) - (document-system 'sb-bsd-sockets :package :sb-bsd-sockets))) + (format t +" +") + (asdf:operate 'asdf:load-op 'sb-bsd-sockets) + (document-system 'sb-bsd-sockets :package :sb-bsd-sockets))) (start)