[Lisppaste-cvs] CVS update: lisppaste2/clhs-lookup.lisp
Brian Mastenbrook
bmastenbrook at common-lisp.net
Thu Jun 3 14:16:16 UTC 2004
Update of /project/lisppaste/cvsroot/lisppaste2
In directory common-lisp.net:/home/bmastenbrook/lisppaste2
Modified Files:
clhs-lookup.lisp
Log Message:
Add back MOP and format lookup
Date: Thu Jun 3 07:16:16 2004
Author: bmastenbrook
Index: lisppaste2/clhs-lookup.lisp
diff -u lisppaste2/clhs-lookup.lisp:1.1 lisppaste2/clhs-lookup.lisp:1.2
--- lisppaste2/clhs-lookup.lisp:1.1 Tue Jun 1 06:41:27 2004
+++ lisppaste2/clhs-lookup.lisp Thu Jun 3 07:16:16 2004
@@ -1,9 +1,9 @@
(defpackage :clhs-lookup (:use :common-lisp) (:export :symbol-lookup
- :populate-table))
+ :populate-table
+ :spec-lookup))
(in-package :clhs-lookup)
-;;; CLHS. This will be the default lookup.
-(defparameter *hyperspec-pathname* #p"/Users/chandler/HyperSpec/")
+(defparameter *hyperspec-pathname* #p"/home/bmastenbrook/HyperSpec/")
(defparameter *hyperspec-map-file* (merge-pathnames "Data/Map_Sym.txt" *hyperspec-pathname*))
@@ -14,8 +14,20 @@
(defparameter *mop-root* "http://www.alu.org/mop/")
-(defvar *table* (make-hash-table :test 'equalp))
+(defvar *symbol-table* (make-hash-table :test 'equalp))
+
+(defvar *section-table* (make-hash-table :test 'equalp))
+
+(defvar *format-table* (make-hash-table :test 'equalp))
+(defun add-clhs-section-to-table (&rest numbers)
+ (let ((key (format nil "~{~d~^.~}" numbers))
+ (target (concatenate 'string *hyperspec-root* (format nil "Body/~2,'0d_~(~{~36r~}~).htm" (car numbers) (mapcar #'(lambda (x) (+ x 9)) (cdr numbers))))))
+ (setf (gethash key *section-table*) target)))
+
+(defun valid-target (&rest numbers)
+ (probe-file (format nil "Body/~2,'0d_~(~{~36r~}~).htm" (car numbers) (mapcar #'(lambda (x) (+ x 9)) (cdr numbers)))))
+
(defun populate-table ()
;; Hyperspec
(with-open-file (s *hyperspec-map-file*)
@@ -24,24 +36,97 @@
(do ((symbol-name (read-line s nil s) (read-line s nil s))
(url (read-line s nil s) (read-line s nil s)))
((eq url s) 'done)
- (setf (gethash symbol-name *table*) (concatenate 'string *hyperspec-root* (subseq url 3))))
+ (setf (gethash symbol-name *symbol-table*) (concatenate 'string *hyperspec-root* (subseq url 3))))
+ ;; add in section references.
+ (let ((*default-pathname-defaults* *hyperspec-pathname*))
+ ;; Yuk. I know. Fixes welcome.
+ (loop for section from 0 to 27
+ do (add-clhs-section-to-table section)
+ do (loop named s for s1 from 1 to 26
+ unless (valid-target section s1)
+ do (return-from s nil)
+ do (add-clhs-section-to-table section s1)
+ do (loop named ss for s2 from 1 to 26
+ unless (valid-target section s1 s2)
+ do (return-from ss nil)
+ do (add-clhs-section-to-table section s1 s2)
+ do (loop named sss for s3 from 1 to 26
+ unless (valid-target section s1 s2 s3)
+ do (return-from sss nil)
+ do (add-clhs-section-to-table section s1 s2 s3)
+ do (loop named ssss for s4 from 1 to 26
+ unless (valid-target section s1 s2 s3 s4)
+ do (return-from ssss nil)
+ do (add-clhs-section-to-table section s1 s2 s3 s4)
+ do (loop named sssss for s5 from 1 to 26
+ unless (valid-target section s1 s2 s3 s4 s5)
+ do (return-from sssss nil)
+ do (add-clhs-section-to-table section s1 s2 s3 s4 s5))))))))
+ ;; format directives
+ (loop for code from 32 to 127
+ do (setf (gethash (format nil "~~~A" (code-char code)) *format-table*)
+ (concatenate 'string
+ *hyperspec-root*
+ (case (code-char code)
+ ((#\c #\C) "Body/22_caa.htm")
+ ((#\%) "Body/22_cab.htm")
+ ((#\&) "Body/22_cac.htm")
+ ((#\|) "Body/22_cad.htm")
+ ((#\~) "Body/22_cae.htm")
+ ((#\r #\R) "Body/22_cba.htm")
+ ((#\d #\D) "Body/22_cbb.htm")
+ ((#\b #\B) "Body/22_cbc.htm")
+ ((#\o #\O) "Body/22_cbd.htm")
+ ((#\x #\X) "Body/22_cbe.htm")
+ ((#\f #\F) "Body/22_cca.htm")
+ ((#\e #\E) "Body/22_ccb.htm")
+ ((#\g #\G) "Body/22_ccc.htm")
+ ((#\$) "Body/22_ccd.htm")
+ ((#\a #\A) "Body/22_cda.htm")
+ ((#\s #\S) "Body/22_cdb.htm")
+ ((#\w #\W) "Body/22_cdc.htm")
+ ((#\_) "Body/22_cea.htm")
+ ((#\<) "Body/22_ceb.htm")
+ ((#\i #\I) "Body/22_cec.htm")
+ ((#\/) "Body/22_ced.htm")
+ ((#\t #\T) "Body/22_cfa.htm")
+ ;; FIXME
+ ((#\<) "Body/22_cfb.htm")
+ ((#\>) "Body/22_cfc.htm")
+ ((#\*) "Body/22_cga.htm")
+ ((#\[) "Body/22_cgb.htm")
+ ((#\]) "Body/22_cgc.htm")
+ ((#\{) "Body/22_cgd.htm")
+ ((#\}) "Body/22_cge.htm")
+ ((#\?) "Body/22_cgf.htm")
+ ((#\() "Body/22_cha.htm")
+ ((#\)) "Body/22_chb.htm")
+ ((#\p #\P) "Body/22_chc.htm")
+ ((#\;) "Body/22_cia.htm")
+ ((#\^) "Body/22_cib.htm")
+ ((#\Newline) "Body/22_cic.htm")
+ (t "Body/22_c.htm")))))
;; glossary.
)
;; MOP
- (with-open-file (s *mop-map-file* :if-does-not-exist nil)
- (when s
- (do ((symbol-name (read-line s nil s) (read-line s nil s))
- (url (read-line s nil s) (read-line s nil s)))
- ((eq url s) 'done)
- (setf (gethash (concatenate 'string "MOP:" symbol-name) *table*) (concatenate 'string *mop-root* url))))))
-
-(defmacro aif (test conseq &optional (else nil))
- `(let ((it ,test))
- (if it ,conseq
- (symbol-macrolet ((it ,test))
- ,else))))
-
-(defun symbol-lookup (str)
- (aif (gethash str *table*)
- it
- nil))
+ (with-open-file (s *mop-map-file*)
+ (do ((symbol-name (read-line s nil s) (read-line s nil s))
+ (url (read-line s nil s) (read-line s nil s)))
+ ((eq url s) 'done)
+ (setf (gethash (concatenate 'string "MOP:" symbol-name) *symbol-table*) (concatenate 'string *mop-root* url)))))
+
+(defun spec-lookup (term &key (type :all))
+ (ecase type
+ (:all
+ (or (gethash term *symbol-table*)
+ (gethash term *section-table*)
+ (gethash term *format-table*)))
+ (:symbol
+ (gethash term *symbol-table*))
+ (:section
+ (gethash term *section-table*))
+ (:format
+ (gethash term *format-table*))))
+
+(defun symbol-lookup (term)
+ (spec-lookup term :type :symbol))
More information about the Lisppaste-cvs
mailing list