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