X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=contrib%2Fbsd-sockets%2Fdoc.lisp;fp=contrib%2Fbsd-sockets%2Fdoc.lisp;h=0000000000000000000000000000000000000000;hb=a78064c13bab180a663238979ae837210c5c9ff4;hp=37cfe36082ad8c2d026711c398ad3d5099045c4c;hpb=10d2c05ea44ca0837091434fe2223c0c31687615;p=sbcl.git diff --git a/contrib/bsd-sockets/doc.lisp b/contrib/bsd-sockets/doc.lisp deleted file mode 100644 index 37cfe36..0000000 --- a/contrib/bsd-sockets/doc.lisp +++ /dev/null @@ -1,225 +0,0 @@ -(eval-when (:load-toplevel :compile-toplevel :execute) - (defpackage :db-doc (:use :cl :asdf #+sbcl :sb-ext #+cmu :ext ))) -(in-package :db-doc) -;;; turn water into wine ^W^W^W lisp into HTML - -#| -OK. We need a design - -1) The aim is to document the current package, given a system. -2) The assumption is that the system is loaded; this makes it easier to -do cross-references and stuff -3) We output HTML on *standard-output* -4) Hyperlink wherever useful -5) We're allowed to intern symbols all over the place if we like - -|# - -;;; note: break badly on multiple packages - - -(defvar *symbols* nil - "List of external symbols to print; derived from parsing DEFPACKAGE form") - - -(defun worth-documenting-p (symbol) - (and symbol - (eql (symbol-package symbol) *package*) - (or (ignore-errors (find-class 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 #\-)))) - (and (every #'symbol-char 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))) -(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))) - -(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))) - (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)))))) - - -(defun do-defpackage (form stream) - (setf *symbols* nil) - (destructuring-bind (defn name &rest options) form - (when (string-equal name (package-name *package*)) - (format stream "

Package ~A

~%" name) - (when (documentation *package* t) - (princ (text-markup (documentation *package* t)))) - (let ((exports (assoc :export options))) - (when exports - (setf *symbols* (mapcar #'symbol-name (cdr exports))))) - 1))) - -(defun do-defclass (form stream) - (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)))) - - -(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=)))) - -(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))) - -(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=))) - (format stream "

(~A ~A)~A
~%" - name (string-downcase (princ-to-string name)) - (string-downcase - (format nil "~{ ~A~}" (markup-lambdalist lambdalist))) - label) - (if (stringp doc) - (format stream "

~A
~%" - (text-markup doc))) - t))) - -(defun do-defun (form stream) (do-defunlike form "Function" stream)) -(defun do-defmethod (form stream) (do-defunlike form "Method" stream)) -(defun do-defgeneric (form stream) (do-defunlike form "Generic Function" stream)) -(defun do-boolean-sockopt (form stream) - (destructuring-bind (type lisp-name level c-name) form - (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) - "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))) - -(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 "
" - )))) - -(defvar *standard-sharpsign-reader* - (get-dispatch-macro-character #\# #\|)) - -(defun document-system (system &key - (output-stream *standard-output*) - (package *package*)) - "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)) - (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)))) - (dolist (c (cclan:all-components 'db-sockets)) - (when (and (typep c 'cl-source-file) - (not (typep c 'db-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 'bsd-sockets) - (document-system 'bsd-sockets :package :bsd-sockets))) - -(start)