Update of /project/cldoc/cvsroot/cldoc/src In directory common-lisp.net:/tmp/cvs-serv6723
Modified Files: html.lisp Log Message: Clean up Date: Fri Dec 16 19:21:58 2005 Author: ihatchondo
Index: cldoc/src/html.lisp diff -u cldoc/src/html.lisp:1.4 cldoc/src/html.lisp:1.5 --- cldoc/src/html.lisp:1.4 Fri Dec 16 11:30:09 2005 +++ cldoc/src/html.lisp Fri Dec 16 19:21:58 2005 @@ -1,5 +1,5 @@ ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLUDG; -*- -;;; $Id: html.lisp,v 1.4 2005/12/16 10:30:09 ihatchondo Exp $ +;;; $Id: html.lisp,v 1.5 2005/12/16 18:21:58 ihatchondo Exp $ ;;; --------------------------------------------------------------------------- ;;; Title: Common Lisp Universal Documentation Generator: HTML driver ;;; Created: 2005 10 23 2:30 @@ -260,12 +260,17 @@ :to (mkout (car (elt list (1- index))))))))
(defun alphabetical-order (desc1 desc2) - "Returns true if the name of the first descriptor is inferior, in the - string-lessp sens." + "Returns true if the name of the first descriptor is lexicographicaly + inferior to the name of the second descriptor." (flet ((get-name (desc) (let ((name (name desc))) (if (starts-with name "(") (subseq name 1) name)))) - (string-lessp (get-name desc1) (get-name desc2)))) + (let ((name1 (get-name desc1)) + (name2 (get-name desc2))) + (if (alpha-char-p (char name1 0)) + (if (alpha-char-p (char name2 0)) (string-lessp name1 name2) T) + (unless (alpha-char-p (char name2 0)) + (string-lessp name1 name2))))))
;;; ;;; Macros for HTML writing. @@ -295,8 +300,9 @@ `(let ((,os ,stream)) (format ,os "<~a~{~^ ~a="~a"~}~:[~;/~]>~%" ,tagname (list ,@attributes) ,(zerop (length body))) - ,@body - ,@(unless (zerop (length body)) `((format ,os "</~a>~%" ,tagname)))))) + (prog1 (progn ,@body) + ,@(unless (zerop (length body)) + `((format ,os "</~a>~%" ,tagname)))))))
(defmacro with-html-page ((os &key csshref content-type head-title nav-name index prev next) @@ -436,32 +442,26 @@
(defun make-index-entry (meta-descriptors &key char-code non-alphabetic filter) (flet ((char-code-string () (format nil "~:@(~c~)..." (code-char char-code))) - (get-first-char (name) + (first-char-p (name char) (let ((c (char name 0))) - (if (char= c #() (char name 1) c))) - (make-entry (name desc href) - (unless (and filter (funcall filter desc)) - (with-tag (:div (:class "index-entry")) - (with-tag (:a (:href href)) - (html-write "~a," (purge-string-for-html name))) - (with-tag (:em ()) - (html-write "~a" (html-printable-type desc))))))) + (char-equal char (if (char= c #() (char name 1) c))))) (with-tag (:a (:id (format nil "_~a" (or char-code non-alphabetic)))) "") (with-tag (:div (:class "abc-entry")) (with-tag (:h3 ()) (html-write (if char-code (char-code-string) "non-alphabetic"))) - (loop for mdesc in meta-descriptors + (loop with entry = (and char-code (code-char char-code)) + for mdesc in meta-descriptors for desc = (meta-descriptor-desc mdesc) - for name = (name desc) - for char1 = (get-first-char name) - if char-code - do (cond ((char-equal (code-char char-code) char1) - (make-entry name desc (meta-descriptor-href mdesc))) - ((char-greaterp char1 (code-char char-code)) - (loop-finish))) - else if non-alphabetic - do (when (or (char-lessp char1 #\A) (char-greaterp char1 #\z)) - (make-entry name desc (meta-descriptor-href mdesc))))))) + if (or (and entry (first-char-p (name desc) entry)) non-alphabetic) + do (unless (and filter (funcall filter desc)) + (with-tag (:div (:class "index-entry")) + (with-tag (:a (:href (meta-descriptor-href mdesc))) + (html-write "~a," (purge-string-for-html (name desc)))) + (with-tag (:em ()) + (html-write "~a" (html-printable-type desc))))) + (pop meta-descriptors) + else do (loop-finish) + finally (return meta-descriptors)))))
(defun write-index (filename dest-dir title html-driver meta-descriptors) (let ((na-anchor (format nil "~a" (gensym))) @@ -478,7 +478,9 @@ (make-abc-index-entry index-file :non-alphabetic na-anchor) ;; the index itself (loop for i from (char-code #\a) to (char-code #\z) - do (make-index-entry meta-descriptors :char-code i :filter filter)) + do (setf meta-descriptors + (make-index-entry + meta-descriptors :char-code i :filter filter))) ;; add non-alphabetic (make-index-entry meta-descriptors @@ -759,7 +761,7 @@ do (with-slots (name type) desc (unless (and filter (funcall filter desc)) (dformat desc hdriver os)))))))))) - *unhandled-forms*)) + (remove-duplicates *unhandled-forms*)))
;;; ;;; Purger.