Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 499e33ecc0
Fetching contributors…

Cannot retrieve contributors at this time

223 lines (204 sloc) 9.653 kb
(defpackage :clhs-lookup (:use :common-lisp) (:export :symbol-lookup
:populate-table
:spec-lookup))
(in-package :clhs-lookup)
(defparameter *hyperspec-pathname*
(merge-pathnames
(make-pathname :directory '(:relative "HyperSpec"))
(user-homedir-pathname)))
(defparameter *hyperspec-map-file*
(merge-pathnames "Data/Map_Sym.txt" *hyperspec-pathname*))
(defparameter *hyperspec-root* "http://www.lispworks.com/reference/HyperSpec/")
;;; AMOP.
(defparameter *mop-map-file*
(merge-pathnames "Mop_Sym.txt"
(or #.*compile-file-truename* *default-pathname-defaults*)))
(defparameter *mop-root* "http://www.alu.org/mop/")
(defvar *symbol-table* (make-hash-table :test 'equalp))
(defvar *abbrev-table* (make-hash-table :test 'equalp))
(defvar *section-table* (make-hash-table :test 'equalp))
(defvar *format-table* (make-hash-table :test 'equalp))
(defvar *read-macro-table* (make-hash-table :test 'equalp))
(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))
(flet ((set-symbol (sym url)
(setf (gethash sym *symbol-table*) url)
(let ((abbrev (abbrev:abbrev sym)))
(and abbrev
(pushnew sym (gethash abbrev *abbrev-table* nil)
:test #'string-equal)))))
(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)
(set-symbol symbol-name (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")))))
;; read macros
(loop for (char page) in '((#\( "a")
(#\) "b")
(#\' "c")
(#\; "d")
(#\" "e")
(#\` "f")
(#\, "g")
(#\# "h"))
do (setf (gethash (format nil "~A" char) *read-macro-table*)
(concatenate 'string
*hyperspec-root*
"Body/02_d"
page
".htm")))
(loop for code from 32 to 127
do (setf (gethash (format nil "#~A" (code-char code)) *read-macro-table*)
(concatenate 'string
*hyperspec-root*
"Body/02_dh"
(case (code-char code)
((#\\) "a")
((#\') "b")
((#\() "c")
((#\*) "d")
((#\:) "e")
((#\.) "f")
((#\b #\B) "g")
((#\o #\O) "h")
((#\x #\X) "i")
((#\r #\R) "j")
((#\c #\C) "k")
((#\a #\A) "l")
((#\s #\S) "m")
((#\p #\P) "n")
((#\=) "o")
((#\#) "p")
((#\+) "q")
((#\-) "r")
((#\|) "s")
((#\<) "t")
((#\)) "v")
(t ""))
".htm")))
;; glossary.
)
;; MOP
(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))))
(setf *populated-p* t)))
(defun abbrev-lookup (term)
(let ((abbrevs (gethash term *abbrev-table* nil)))
(if (eql (length abbrevs) 0)
nil
(if (eql (length abbrevs) 1)
(format nil "~A: ~A"
(car abbrevs)
(gethash (car abbrevs) *symbol-table*))
(format nil "Matches: ~{~A~^ ~}"
abbrevs)))))
(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*)
(gethash term *read-macro-table*)
(abbrev-lookup term)))
(:abbrev
(abbrev-lookup term))
(:symbol
(gethash term *symbol-table*))
(:section
(gethash term *section-table*))
(:format
(gethash term *format-table*))
(:read-macro
(gethash term *read-macro-table*))))
(defun symbol-lookup (term)
(spec-lookup term :type :symbol))
Jump to Line
Something went wrong with that request. Please try again.