diff options
Diffstat (limited to 'Lisp/moxie/clhs-lookup.lisp')
| -rw-r--r-- | Lisp/moxie/clhs-lookup.lisp | 148 |
1 files changed, 148 insertions, 0 deletions
diff --git a/Lisp/moxie/clhs-lookup.lisp b/Lisp/moxie/clhs-lookup.lisp new file mode 100644 index 0000000..02a3a32 --- /dev/null +++ b/Lisp/moxie/clhs-lookup.lisp @@ -0,0 +1,148 @@ +(defpackage clhs-lookup + (:use :common-lisp) + (:export :symbol-lookup + :populate-table + :spec-lookup)) +(in-package :clhs-lookup) + +(defparameter *hyperspec-pathname* (translate-logical-pathname "MOXIE:RES;")) + +(defparameter *hyperspec-map-file* (merge-pathnames "Map_Sym.txt" *hyperspec-pathname*)) + +(defparameter *hyperspec-root* "http://www.lispworks.com/reference/HyperSpec/") + +;;; AMOP. +(defparameter *mop-map-file* (merge-pathnames "Mop_Sym.txt" *hyperspec-pathname*)) + +(defparameter *mop-root* "http://www.alu.org/mop/") + +(defvar *symbol-table* (make-hash-table :test 'equal)) + +(defvar *section-table* (make-hash-table :test 'equal)) + +(defvar *format-table* (make-hash-table :test 'equal)) + +(defvar *populated-p* nil) + +(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))))) + +(defvar *last-warn-time* 0) + +(defun populate-table () + (unless *populated-p* + ;; Hyperspec + (with-open-file (s *hyperspec-map-file* :if-does-not-exist nil) + ;; populate the table with the symbols from the Map file + ;; this bit is easy and portable. + (unless s + (when (> (- (get-universal-time) *last-warn-time*) 10) + (format *trace-output* "Warning: could not find hyperspec map file. Adjust the path at the top of clhs-lookup.lisp to get links to the HyperSpec.~%") + (setf *last-warn-time* (get-universal-time))) + (return-from populate-table nil)) + (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 *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) *symbol-table*) (concatenate 'string *mop-root* url))))) + (setf *populated-p* t))) + +(defun spec-lookup (term &key (type :all)) + (unless *populated-p* + (populate-table)) + (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)) |