[cldoc-cvs] CVS update: cldoc/src/html.lisp

[Iban Hatchondo]

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 , at attributes) ,(zerop (length body)))
-       , at body
-       ,@(unless (zerop (length body)) `((format ,os "</~a>~%" ,tagname))))))
+       (prog1 (progn , at 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.