April 2004 - hyperdoc-cvs@common-lisp.net

[hyperdoc-cvs] CVS update: src/slime.patch
by Nikodemus Siivola 24 Apr '04

24 Apr '04

Update of /project/hyperdoc/cvsroot/src In directory common-lisp.net:/tmp/cvs-serv24215 Modified Files: slime.patch Log Message: Use the new lookup interface. Date: Sat Apr 24 16:55:46 2004 Author: nsiivola Index: src/slime.patch diff -u src/slime.patch:1.2 src/slime.patch:1.3 --- src/slime.patch:1.2 Sat Apr 24 16:07:03 2004 +++ src/slime.patch Sat Apr 24 16:55:46 2004 @@ -5,7 +5,7 @@ retrieving revision 1.275 diff -u -r1.275 slime.el --- slime.el 23 Apr 2004 22:09:11 -0000 1.275 -+++ slime.el 24 Apr 2004 20:06:19 -0000 ++++ slime.el 24 Apr 2004 20:54:56 -0000 @@ -485,7 +485,7 @@ ("\C-m" slime-macroexpand-1 :prefixed t :inferior t) ("\M-m" slime-macroexpand-all :prefixed t :inferior t) @@ -42,7 +42,7 @@ retrieving revision 1.83 diff -u -r1.83 swank-sbcl.lisp --- swank-sbcl.lisp 6 Apr 2004 10:42:53 -0000 1.83 -+++ swank-sbcl.lisp 24 Apr 2004 20:06:19 -0000 ++++ swank-sbcl.lisp 24 Apr 2004 20:54:56 -0000 @@ -40,6 +40,7 @@ (require 'sb-bsd-sockets) (require 'sb-introspect) @@ -57,13 +57,16 @@ retrieving revision 1.171 diff -u -r1.171 swank.lisp --- swank.lisp 22 Apr 2004 21:37:50 -0000 1.171 -+++ swank.lisp 24 Apr 2004 20:06:20 -0000 -@@ -2063,6 +2063,9 @@ ++++ swank.lisp 24 Apr 2004 20:54:57 -0000 +@@ -2063,6 +2063,12 @@ (with-connection (connection) (simple-break)))))) -+(defslimefun hyperdoc (name) -+ (hyperdoc:lookup (find-symbol-designator name *buffer-package*))) ++(defslimefun hyperdoc (string) ++ (multiple-value-bind (name package-name internal-p) ++ (tokenize-symbol-designator (case-convert-input string)) ++ (declare (ignore internal-p)) ++ (hyperdoc:lookup package-name name))) + ;;; Local Variables: ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-keyword-face) (2 font-lock-function-name-face))))

1 0

[hyperdoc-cvs] CVS update: src/slime.patch
by Nikodemus Siivola 24 Apr '04

24 Apr '04

Update of /project/hyperdoc/cvsroot/src In directory common-lisp.net:/tmp/cvs-serv16212 Modified Files: slime.patch Log Message: Patch for current Slime. Date: Sat Apr 24 16:07:03 2004 Author: nsiivola Index: src/slime.patch diff -u src/slime.patch:1.1.1.1 src/slime.patch:1.2 --- src/slime.patch:1.1.1.1 Mon Nov 17 10:28:47 2003 +++ src/slime.patch Sat Apr 24 16:07:03 2004 @@ -1,34 +1,26 @@ -? slime.patch +? fasl Index: slime.el =================================================================== RCS file: /project/slime/cvsroot/slime/slime.el,v -retrieving revision 1.91 -diff -u -r1.91 slime.el ---- slime.el 13 Nov 2003 22:42:08 -0000 1.91 -+++ slime.el 14 Nov 2003 18:51:42 -0000 -@@ -56,7 +56,8 @@ - (require 'cl) - (require 'pp) - (require 'hideshow) --(require 'hyperspec) -+(require 'browse-url) -+;(require 'hyperspec) - (require 'font-lock) - (when (featurep 'xemacs) - (require 'overlay)) -@@ -368,7 +369,7 @@ +retrieving revision 1.275 +diff -u -r1.275 slime.el +--- slime.el 23 Apr 2004 22:09:11 -0000 1.275 ++++ slime.el 24 Apr 2004 20:06:19 -0000 +@@ -485,7 +485,7 @@ ("\C-m" slime-macroexpand-1 :prefixed t :inferior t) ("\M-m" slime-macroexpand-all :prefixed t :inferior t) ("\M-0" slime-restore-window-configuration :prefixed t :inferior t) -- ("\C-h" hyperspec-lookup :prefixed t :inferior t :sldb t) +- ("\C-h" slime-hyperspec-lookup :prefixed t :inferior t :sldb t) + ("\C-h" slime-hyperdoc-key :prefixed t :inferior t :sldb t) ([(control meta ?\.)] slime-next-location :inferior t) - ("\C- " slime-next-location :prefixed t :inferior t) - ("~" slime-sync-package-and-default-directory :prefixed t :inferior t) -@@ -4135,6 +4136,19 @@ + ;; Emacs20 on LinuxPPC signals a + ;; "Invalid character: 400000040, 2147479172, 0xffffffd8" +@@ -6619,6 +6619,20 @@ + (defun sldb-xemacs-post-command-hook () + (when (get-text-property (point) 'point-entered) (funcall (get-text-property (point) 'point-entered)))) - - ++ ++ +;;; Hyperdoc +(defun slime-hyperdoc-key () + (interactive) @@ -41,52 +33,38 @@ + (slime-buffer-package) + (lambda (uri) + (browse-url uri)))) -+ - ;;; Finishing up - (run-hooks 'slime-load-hook) + + ;;; Finishing up Index: swank-sbcl.lisp =================================================================== RCS file: /project/slime/cvsroot/slime/swank-sbcl.lisp,v -retrieving revision 1.22 -diff -u -r1.22 swank-sbcl.lisp ---- swank-sbcl.lisp 13 Nov 2003 00:36:56 -0000 1.22 -+++ swank-sbcl.lisp 14 Nov 2003 18:51:42 -0000 -@@ -38,8 +38,10 @@ - ;;; Administrivia - - (eval-when (:compile-toplevel :load-toplevel :execute) -+ (require :asdf) +retrieving revision 1.83 +diff -u -r1.83 swank-sbcl.lisp +--- swank-sbcl.lisp 6 Apr 2004 10:42:53 -0000 1.83 ++++ swank-sbcl.lisp 24 Apr 2004 20:06:19 -0000 +@@ -40,6 +40,7 @@ (require 'sb-bsd-sockets) -- (require 'sb-introspect)) -+ (require 'sb-introspect) -+ (require 'hyperdoc)) + (require 'sb-introspect) + (require 'sb-posix) ++ (require 'hyperdoc) + ) (declaim (optimize (debug 3))) - (in-package :swank) -@@ -649,6 +651,10 @@ - - (defslimefun sldb-abort () - (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name))) -+ -+;;; Hax -+(defslimefun hyperdoc (name) -+ (hyperdoc:lookup (find-symbol-designator name *buffer-package*))) - - ;;; Local Variables: - ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-keyword-face) (2 font-lock-function-name-face)))) Index: swank.lisp =================================================================== RCS file: /project/slime/cvsroot/slime/swank.lisp,v -retrieving revision 1.57 -diff -u -r1.57 swank.lisp ---- swank.lisp 13 Nov 2003 00:22:01 -0000 1.57 -+++ swank.lisp 14 Nov 2003 18:51:43 -0000 -@@ -518,7 +518,6 @@ - (defslimefun throw-to-toplevel () - (throw 'slime-toplevel nil)) +retrieving revision 1.171 +diff -u -r1.171 swank.lisp +--- swank.lisp 22 Apr 2004 21:37:50 -0000 1.171 ++++ swank.lisp 24 Apr 2004 20:06:20 -0000 +@@ -2063,6 +2063,9 @@ + (with-connection (connection) + (simple-break)))))) -- ++(defslimefun hyperdoc (name) ++ (hyperdoc:lookup (find-symbol-designator name *buffer-package*))) ++ ;;; Local Variables: ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-keyword-face) (2 font-lock-function-name-face)))) ;;; End:

1 0

[hyperdoc-cvs] CVS update: src/LICENSE
by Nikodemus Siivola 24 Apr '04

24 Apr '04

Update of /project/hyperdoc/cvsroot/src In directory common-lisp.net:/tmp/cvs-serv14016 Modified Files: LICENSE Log Message: ;; cleanup Date: Sat Apr 24 16:05:41 2004 Author: nsiivola Index: src/LICENSE diff -u src/LICENSE:1.1 src/LICENSE:1.2 --- src/LICENSE:1.1 Sat Apr 24 16:04:40 2004 +++ src/LICENSE Sat Apr 24 16:05:41 2004 @@ -1,20 +1,20 @@ -;; Copyright (c) 2003 Nikodemus Siivola +Copyright (c) 2003, 2004 Nikodemus Siivola -;; Permission is hereby granted, free of charge, to any person obtaining -;; a copy of this software and associated documentation files (the -;; "Software"), to deal in the Software without restriction, including -;; without limitation the rights to use, copy, modify, merge, publish, -;; distribute, sublicense, and/or sell copies of the Software, and to -;; permit persons to whom the Software is furnished to do so, subject to -;; the following conditions: +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: -;; The above copyright notice and this permission notice shall be -;; included in all copies or substantial portions of the Software. +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. -;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE -;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION -;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION -;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

1 0

[hyperdoc-cvs] CVS update: src/.cvsignore src/CREDITS src/LICENSE src/hyperspec-lookup.patch src/hyperdoc.lisp src/Makefile src/hyperdoc.patch
by Nikodemus Siivola 24 Apr '04

24 Apr '04

Update of /project/hyperdoc/cvsroot/src In directory common-lisp.net:/tmp/cvs-serv8307 Modified Files: hyperdoc.lisp Added Files: .cvsignore CREDITS LICENSE hyperspec-lookup.patch Removed Files: Makefile hyperdoc.patch Log Message: Restructuring, initial version of static indices Date: Sat Apr 24 16:04:40 2004 Author: nsiivola Index: src/hyperdoc.lisp diff -u src/hyperdoc.lisp:1.2 src/hyperdoc.lisp:1.3 --- src/hyperdoc.lisp:1.2 Tue Nov 18 12:01:38 2003 +++ src/hyperdoc.lisp Sat Apr 24 16:04:40 2004 @@ -1,29 +1,31 @@ -;; Copyright (c) 2003 Nikodemus Siivola - -;; Permission is hereby granted, free of charge, to any person obtaining -;; a copy of this software and associated documentation files (the -;; "Software"), to deal in the Software without restriction, including -;; without limitation the rights to use, copy, modify, merge, publish, -;; distribute, sublicense, and/or sell copies of the Software, and to -;; permit persons to whom the Software is furnished to do so, subject to -;; the following conditions: - -;; The above copyright notice and this permission notice shall be -;; included in all copies or substantial portions of the Software. - -;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE -;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION -;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION -;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +;;;; Copyright (c) 2003, 2004 Nikodemus Siivola +;;;; +;;;; Permission is hereby granted, free of charge, to any person obtaining +;;;; a copy of this software and associated documentation files (the +;;;; "Software"), to deal in the Software without restriction, including +;;;; without limitation the rights to use, copy, modify, merge, publish, +;;;; distribute, sublicense, and/or sell copies of the Software, and to +;;;; permit persons to whom the Software is furnished to do so, subject to +;;;; the following conditions: +;;;; +;;;; The above copyright notice and this permission notice shall be +;;;; included in all copies or substantial portions of the Software. +;;;; +;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +;;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +;;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +;;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. (defpackage :hyperdoc (:use :cl) (:export #:lookup #:base-uri + #:generate-index + #:*index-directory* )) (in-package :hyperdoc) @@ -31,73 +33,259 @@ ;;;; Utility functions (defun find-value (name package) + "Returns the symbol-value of the symbol NAME in PACKAGE, and T as a +secondary value if the symbol is bound. Returns NIL, NIL if the symbol +doesn't exist or is not bound." (let ((symbol (find-symbol name package))) (if (and symbol (boundp symbol)) (values (symbol-value symbol) t) (values nil nil)))) -(defun merge-uris (base relative) +(defun find-function (name package) + "Returns the symbol-funciton of the symbol NAME in PACKAGE, and T as +a secondary value if the symbol is fbound. Returns NIL, NIL if the +symbol doesn't exist or is not fbound." + (let ((symbol (find-symbol name package))) + (if (and symbol (fboundp symbol)) + (symbol-function symbol) + nil))) + +(defun merge-uris (relative base) + "Merges RELATIVE to BASE." ;; Yuck. This is so WRONG. (concatenate 'string base relative)) (defun package-string (package) + "Returns the name of the designated 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)) +(defun hash-alist (hash) + "Returns an alist corresponding to the HASH." + (let (alist) + (maphash (lambda (key value) + (push (cons key value) alist)) + hash) + alist)) + +(defun alist-hash (alist &key (test #'eql)) + "Returns a hash corresponding to the ALIST." + (let ((hash (make-hash-table :test test))) + (dolist (x alist) + (setf (gethash (car x) hash) (cdr x))) + hash)) + +;;;; Varaibles + +(defvar *index* nil + "In memory index. FIXME: This should be loaded when hyperdoc is +loaded -- or at least lazily on first call to X.") + +(defvar *index-directory* (merge-pathnames ".hyperdoc/" (user-homedir-pathname)) + "The directory where Hyperdoc keeps the pregenerated indices.") + +(defvar *name-index-version* "Hyperdoc Name Index -- Version 1" + "Magic version indentifier used in the name index files.") + +(defvar *package-index-version* "Hyperdoc Package Index -- Version 1" + "Magic version indentifier used in the package index files.") + +(defvar *index-herald* + ";;;; This is an automatically generated index -- do not edit by hand! +;;;; See http://www.common-lisp.net/project/hyperdoc/ for more information." + "Herald printed in the beginning of the index file to discourage tampering.") + +(defparameter *documentation-types* + (list "T" "SYMBOL-MACRO" "MACRO" "CONDITION" "METHOD" + "GENERIC-FUNCTION" "CLASS" "TYPE" "FUNCTION" "COMPILER-MACRO" "SETF" + "METHOD-COMBINATION" "TYPE" "STRUCTURE" + "VARIABLE" "CONSTANT") + "Names string of documentation types used by Hyperdoc. These +correspond to what DOCUMENTATION uses with a few additions.") -;;;; The meat and the bones +(defvar *base-uris* (make-hash-table :test #'equal) + "Holds the locally defined base-uris of various packages. Accessed via BASE-URI and (SETF BASE-URI).") -(defvar *base-uris* (make-hash-table :test 'equal)) +;;;; The meat and the bones (defun base-uri (package) "Base URI for hyperdocs for package." (or (gethash (package-string package) *base-uris*) - (symbol-value (find-symbol "*HYPERDOC-BASE-URI*" package)) + (find-value "*HYPERDOC-BASE-URI*" 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." (setf (gethash (package-string package) *base-uris*) uri)) -(defun lookup-all-types (lookup package symbol) - (declare (symbol lookup)) - (let (uris) - (dolist (doc-type (append *hyperdoc-types* - (find-value "*HYPERDOC-EXTRA-TYPES*" package))) - (let ((uri (funcall lookup symbol doc-type))) - (when uri - (pushnew (cons doc-type uri) uris :key 'cdr :test 'equal)))) - uris)) - -(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.)" +(defun lookup (package-designator symbol-name &optional doc-type) + "Look up documentation URI-string for the named symbol of doc-type +in the designated package. If the package is not loaded pregenerated +indices are used. + +If package doesn't support Hyperdoc, or no documentation for the named +symbol is found, a call to hyperspec:lookup with the symbol-name is +attempted. + +If the package supports Hyperdoc, but no doc-type is given and there +are multiple matches, a list of applicable (doc-type . uri-string) +pairs is returned -- if only single doc-type matches just the URI is +returned." + (let* ((package (find-package package-designator)) + (uris + (or (if package + (introspective-lookup (intern symbol-name package) doc-type) + (index-lookup (package-string package-designator) + symbol-name doc-type)) + (hyperspec:lookup symbol-name)))) + (if (and (listp uris) (null (cdr uris))) + (cdr (first uris)) + uris))) + +(defun introspective-lookup (symbol &optional doc-type) + "Looks up hyperdocumentation for the symbol in the current image." + (let ((base-uri (base-uri (symbol-package symbol)))) + (mapcar (lambda (pair) + (cons (car pair) (merge-uris (cdr pair) base-uri))) + (%lookup symbol doc-type)))) + +(defun index-lookup (package-name symbol-name doc-type) + "Looks up hyperdocumentation for the symbol in the pregenerated indices." + (unless *index* + (setf *index* (read-index))) + (let* ((name (gethash package-name (name-table *index*))) + (base-uri (gethash name (base-uri-table *index*)))) + (mapcar (lambda (pair) + (cons (car pair) (merge-uris (cdr pair) base-uri))) + (let ((uris (gethash symbol-name + (gethash name (package-table *index*))))) + (if doc-type + (assoc doc-type uris) + uris))))) + +(defun %lookup (symbol &optional doc-type) + "Primitive for introspective hyperdoc lookup. Doesn't merge the uris." (let* ((package (symbol-package symbol)) (lookup (find-symbol "HYPERDOC-LOOKUP" package))) - (if lookup - (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 (car pair) (merge-uris base (cdr pair)))) - (lookup-all-types lookup package symbol)))) - (hyperspec:lookup (symbol-name symbol))))) + (when lookup + (remove-duplicates (mapcan (lambda (type) + (let ((uri (funcall lookup symbol type))) + (when uri + (list (cons type uri))))) + (if doc-type + (list doc-type) + (all-documentation-types package))) + :test #'string= + :key #'cdr)))) + +(defun all-documentation-types (package) + (union *documentation-types* + (find-symbol "*HYPERDOC-DOCUMENTATION-TYPES*" package) + :test #'string=)) + +(defun name-index-pathname () + (merge-pathnames "names.sexp" *index-directory*)) + +(defun package-index-pathname (package) + (merge-pathnames (make-pathname :name (package-string package) + :type "sexp" ) + (merge-pathnames "packages/" *index-directory*))) + +;;;; Static indexes + +(defclass index () + ((names :accessor name-table + :initform (make-hash-table :test #'equal)) + (base-uris :accessor base-uri-table + :initform (make-hash-table :test #'equal)) + (package-tables :accessor package-table + :initform (make-hash-table :test #'equal)))) + +(defun generate-index (package-designator) + "Generate Hyperdoc index for the designated package." + (unless *index* + (setf *index* (read-index))) + (let* ((package (or (find-package package-designator) + (error "No such package: ~S." package-designator))) + (name (package-name package)) + (all-names (cons name (package-nicknames package))) + (base-uri (base-uri package)) + (name-table (name-table *index*)) + (base-uri-table (base-uri-table *index*)) + (package-table (package-table *index*))) + + ;; Clear old entries + (let (old-name) + (maphash (lambda (key value) + (when (member key all-names :test #'string=) + (setf old-name value) + (remhash key name-table))) + name-table) + (remhash old-name base-uri-table) + (remhash old-name package-table) + ;; Handle case where the canonical name has changed + (when (gethash old-name name-table) + (remhash old-name name-table))) + + ;; New entries + (dolist (n all-names) + (setf (gethash n name-table) name)) + (setf (gethash name base-uri-table) base-uri) + (let ((symbol-table (make-hash-table :test #'equal))) + (do-external-symbols (sym package) + (let ((docs (%lookup sym))) + (when docs + (setf (gethash (symbol-name sym) symbol-table) docs)))) + (setf (gethash name package-table) symbol-table)) + + ;; Save + (ensure-directories-exist *index-directory*) + (with-standard-io-syntax + (with-open-file (f (name-index-pathname) + :direction :output + :if-exists :rename) + (write-line *index-herald* f) + (prin1 *name-index-version* f) + (terpri f) + (prin1 (hash-alist name-table) f) + (terpri f)) + (let ((package-index (package-index-pathname name))) + (ensure-directories-exist package-index) + (with-open-file (f package-index + :direction :output + :if-exists :rename) + (write-line *index-herald* f) + (prin1 *package-index-version* f) + (terpri f) + (prin1 `(("BASE-URI" . ,base-uri) + ("SYMBOLS" . ,(hash-alist (gethash name package-table)))) + f) + (terpri f)))))) + +(defun read-index () + (let ((index (make-instance 'index)) + (names (with-open-file (f (name-index-pathname)) + (unless (equal *name-index-version* (read f)) + (error "Name index version mismatch. Oh dear.")) + (read f)))) + (dolist (n names) + (setf (gethash (car n) (name-table index)) (cdr n))) + (maphash (lambda (nick name) + (declare (ignore nick)) + (with-open-file (f (package-index-pathname name)) + (unless (equal *package-index-version* (read f)) + (error "Package index version mismatch. Opps.")) + (let ((package-index (read f))) + (setf (gethash name (package-table index)) + (alist-hash (cdr (assoc "SYMBOLS" package-index + :test #'string=)) + :test #'equal)) + (setf (gethash name (base-uri-table index)) + (cdr (assoc "BASE-URI" package-index :test #'string=)))))) + (name-table index)) + index)) ;;;; Introspection @@ -105,4 +293,5 @@ (defun hyperdoc-lookup (symbol doc-type) (declare (ignore doc-type)) - #+nil (concatenate 'string "index.html#" (string-downcase (symbol-name symbol)))) + #+nil + (concatenate 'string "index.html#" (string-downcase (symbol-name symbol))))

1 0