[hyperdoc-cvs] CVS update: src/hyperdoc.lisp

[Nikodemus Siivola]

Update of /project/hyperdoc/cvsroot/src
In directory common-lisp.net:/tmp/cvs-serv10079

Modified Files:
	hyperdoc.lisp 
Log Message:
API tweaking.
Date: Tue Nov 18 12:01:45 2003
Author: nsiivola

Index: src/hyperdoc.lisp
diff -u src/hyperdoc.lisp:1.1.1.1 src/hyperdoc.lisp:1.2
--- src/hyperdoc.lisp:1.1.1.1	Mon Nov 17 10:28:48 2003
+++ src/hyperdoc.lisp	Tue Nov 18 12:01:38 2003
@@ -40,45 +40,62 @@
   ;; Yuck. This is so WRONG.
   (concatenate 'string base relative))
 
+(defun package-string (package)
+  (etypecase package
+    (string package)
+    (symbol (symbol-name package))
+    (package (package-name package))))
+
+(defparameter *hyperdoc-types* 
+  ;; These correspond to what DOCUMENTATION uses, plus macro-function
+  ;; and and symbol-function.
+  '(t symbol-function macro-function
+    function compiler-macro setf method-combination type structure
+    variable))
+
 ;;;; The meat and the bones
 
-(defvar *base-uris* ())
+(defvar *base-uris* (make-hash-table :test 'equal))
 
 (defun base-uri (package)
-  "Base URI for hyperdocs for PACKAGE."
-  (or (cdr (assoc-if (lambda (id) 
-		       (eq package (find-package id)))
-		     *base-uris*))
+  "Base URI for hyperdocs for package."
+  (or (gethash (package-string package) *base-uris*)
       (symbol-value (find-symbol "*HYPERDOC-BASE-URI*" package))
-      (error "No base URI for package ~A." (package-name package))))
+      (error "No base URI for package ~A." (package-string package))))
 
 (defun (setf base-uri) (uri package)
-  "Set new base URI for hyperdocs for PACKAGE."
-  (push (cons package uri) *base-uris*))
-
+  "Set new base URI for hyperdocs for PACKAGE."  
+  (setf (gethash (package-string package) *base-uris*) uri))
 
 (defun lookup-all-types (lookup package symbol)
   (declare (symbol lookup))
   (let (uris)
-    (dolist (doc-type (list* 't 'function 'compiler-macro 'setf 
-			     'method-combination 'type 'structure 'variable
-			     (find-value "*HYPERDOC-EXTRA-TYPES*" package)))
+    (dolist (doc-type (append *hyperdoc-types* 
+			      (find-value "*HYPERDOC-EXTRA-TYPES*" package)))
       (let ((uri (funcall lookup symbol doc-type)))
-	(when (and uri (not (assoc uri uris :test 'equal)))
-	  (push (cons uri (symbol-name doc-type)) uris))))
+	(when uri
+	  (pushnew (cons doc-type uri) uris :key 'cdr :test 'equal))))
     uris))
 
-(defun lookup (symbol &optional doc-type)
-  "Look up hyperdoc URI(s) for SYMBOL of DOC-TYPE." 
+(defun lookup (symbol &optional (doc-type nil doc-type-p))
+  "Look up hyperdoc URI-string for symbol of doc-type. if no doc-type
+is given, returns an list of applicable (doc-type . uri-string)
+pairs.
+
+The considered doc-types are the same ones ANSI specifies for DOCUMENTATION,
+plus symbol-function and symbol-macro. These are intended to represent subsets
+of function. (ANSI used DOCUMENTATION symbol 'function for both macros and
+functions.)"
   (let* ((package (symbol-package symbol))
 	 (lookup (find-symbol "HYPERDOC-LOOKUP" package)))
     (if lookup
-	(let ((uri (funcall lookup symbol doc-type))
-	      (base (base-uri package)))
-	  (if (or uri doc-type)
-	      (merge-uris base uri)
+	(let ((base (base-uri package)))
+	  (if doc-type-p
+	      (let ((uri (funcall lookup symbol doc-type)))
+		(when uri 
+		  (merge-uris base uri)))
 	      (mapcar (lambda (pair)
-			(cons (merge-uris base (car pair)) (cdr pair)))
+			(cons (car pair) (merge-uris base (cdr pair))))
 		      (lookup-all-types lookup package symbol))))
 	(hyperspec:lookup (symbol-name symbol)))))