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