-
Notifications
You must be signed in to change notification settings - Fork 11
/
clhs-lookup.lisp
223 lines (205 loc) · 9.46 KB
/
clhs-lookup.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
(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)
(when colorize:*debug*
(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))