-
Notifications
You must be signed in to change notification settings - Fork 2
/
bibtex.lisp
306 lines (276 loc) · 11.3 KB
/
bibtex.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
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
;; A BibTeX re-implementation in Common Lisp - the BibTeX program
;; Copyright 2001, 2002 Matthias Koeppe <[email protected]>
;;
;; This code is free software; you can redistribute it and/or
;; modify it under the terms of version 2.1 of the GNU Lesser
;; General Public License as published by the Free Software
;; Foundation or any later version, as clarified by the preamble
;; found in COPYING-preamble.txt. This preamble is in the style
;; of the Franz Inc. preamble at http://opensource.franz.com/preamble.html
;; with names and copyright holders altered accordingly.
(in-package :bibtex-compiler)
(defvar +version+ "1.0.1")
;;; The compiler front-end
(defvar *bibtex-pprint-dispatch*
(let ((pprint-dispatch (copy-pprint-dispatch)))
#-clisp ; CLISP says "Lisp stack overflow. RESET"
(set-pprint-dispatch '(cons (member DEFINE-BIBTEX-STYLE))
(lambda (*standard-output* obj)
(pprint-logical-block (*standard-output* obj :prefix "(" :suffix ")")
(write (pprint-pop))
(write-char #\Space)
(pprint-newline :miser)
(pprint-indent :current 0)
(write (pprint-pop))
(pprint-indent :block 1)
(pprint-newline :mandatory)
(write (pprint-pop))
(loop (pprint-exit-if-list-exhausted)
(write-char #\Space)
(pprint-newline :linear)
(write (pprint-pop)))))
0
pprint-dispatch)
pprint-dispatch))
(defun make-entry-type-function-alist ()
(loop for fun being each hash-value in *bst-functions*
when (and (member (bst-function-type fun)
'(wizard-defined compiled-wiz-defined))
(null (bst-function-argument-types fun))
(null (bst-function-result-types fun))
(side-effects-side-effects-p
(bst-function-side-effects fun)))
collect (cons (bst-function-name fun)
(bst-function-lisp-name fun))))
(defun make-macro-set-forms ()
(loop for macro being each hash-key in *bib-macros*
and value being each hash-value in *bib-macros*
nconcing `((gethash ,macro *bib-macros*) ,value) into setf-args
finally (return (if (null setf-args)
'()
`((setf ,@setf-args))))))
(defun compile-bst-file (bst-file lisp-file &key (make-variables-lexical t)
(make-variables-constant t))
"Compile the BibTeX style file BST-FILE to a Common Lisp BibTeX
style file LISP-FILE. If :MAKE-VARIABLES-LEXICAL or
:MAKE-VARIABLES-CONSTANT is true (the default), make a second compiler
pass, where some variables are turned into lexical variables or
constant variables."
(with-open-file (bst-stream bst-file)
(let* ((package-name (concatenate 'string "BIBTEX-STYLE-"
(string-upcase
(pathname-name bst-file))))
(use-list '("COMMON-LISP" "BIBTEX-RUNTIME" "BIBTEX-COMPILER"))
(temp-package-name (gentemp "BIBTEX-STYLE-"))
temp-package)
(unwind-protect
(progn
(setq temp-package (make-package temp-package-name :use use-list))
(let* ((*bst-package* temp-package)
(*bib-entries-symbol* (bst-intern "BIB-ENTRIES"))
(*bib-macros* (make-hash-table :test #'equalp))
(*bst-compiling* t)
(*main-lisp-body* '())
(*bst-definition-sequence* '())
(*bst-function-call-sequence* '())
(*bst-functions* (builtin-bst-functions)))
(get-bst-commands-and-process bst-stream)
(let* ((constants (and make-variables-constant
(make-some-variables-constant)))
(*lexicals* (and make-variables-lexical
(make-some-variables-lexical))))
(when constants
(format *error-output* "~&Making variables constant: ~{ ~S~}~%"
constants))
(when *lexicals*
(format *error-output* "~&Making variables lexical: ~{ ~S~}~%"
*lexicals*))
(when (or *lexicals* constants)
;; Recompile with lexical and constant variables
(dolist (bst-function (reverse *bst-definition-sequence*))
(when (and (bst-function-p bst-function)
(eq (bst-function-type bst-function)
'compiled-wiz-defined))
(compile-bst-function bst-function))))
(with-open-file (lisp-stream lisp-file :direction :output)
(flet ((lisp-write (arg)
(let ((*print-case* :downcase)
(*print-length* nil)
(*print-pprint-dispatch* *bibtex-pprint-dispatch*)
(*package* *bst-package*))
(pprint arg lisp-stream))
(terpri lisp-stream)))
(format lisp-stream
";;;; This is a -*- Common-Lisp -*- program, automatically translated~%~
~&;;;; from the BibTeX style file `~A'~%~
~&;;;; by the CL-BibTeX compiler (version ~A).~%"
(namestring bst-file) +version+)
(lisp-write
`(defpackage ,package-name
(:use ,@use-list)
(:shadow
,@(sort (mapcar #'copy-symbol
(package-shadowing-symbols
*bst-package*))
#'string-lessp :key #'symbol-name))))
(lisp-write `(in-package ,package-name))
(dolist (item (reverse *bst-definition-sequence*))
(etypecase item
(string ; a comment
(princ item lisp-stream))
(bst-function ; a variable or wizard-defined function
(case (bst-function-type item)
((int-global-var str-global-var)
(cond
((bst-function-lexical-p item)
nil)
((bst-function-constant-p item)
(lisp-write `(defconstant ,(bst-function-lisp-name item)
,(bst-function-assigned-value-form item))))
(t
(lisp-write `(defvar ,(bst-function-lisp-name item)
,(bst-function-value item))))))
(compiled-wiz-defined
(print-bst-function-info item lisp-stream)
(lisp-write (bst-function-defun-form item)))))))
(lisp-write `(define-bibtex-style ,(pathname-name bst-file)
(let ((*bib-entry-type-functions*
',(make-entry-type-function-alist))
,*bib-entries-symbol*)
,@(make-macro-set-forms)
,@(reverse *main-lisp-body*)))))))))
(delete-package temp-package)))))
;;; The BibTeX program
(defvar *bibtex-styles* '()
"An alist mapping BibTeX styles (strings) to thunk designators that
implement the BibTeX style. Use REGISTER-BIBTEX-STYLE to put items
here.")
(defvar *allow-load-lisp-bibtex-style* t
"Non-nil if a Lisp BibTeX style is allowed to be located via
KPSEARCH and loaded into the Lisp image. (This might be seen as a
security risk, because Lisp programs are much more powerful than BST
scripts.)")
(defvar *registered-bibtex-style* nil)
(defun register-bibtex-style (name thunk)
"Register a BibTeX style, implemented as THUNK (a function
designator), under NAME."
(setq *registered-bibtex-style* (cons name thunk))
(push *registered-bibtex-style* *bibtex-styles*))
(defmacro define-bibtex-style (name &body body)
(let ((function-name
(gentemp (concatenate 'string "BIBTEX-STYLE-" (string name)))))
`(progn (defun ,function-name () ,@body)
(register-bibtex-style ',name ',function-name))))
(defun interpreted-bibtex-style (bst-file)
"Return a thunk that implements the BibTeX style of the BST-FILE
by running the BST interpreter."
(lambda ()
(with-open-file (bst-stream bst-file :if-does-not-exist nil)
(unless bst-stream
(bib-fatal "I couldn't open style file `~A'" bst-file))
(let ((*literal-stack* nil))
(get-bst-commands-and-process bst-stream)))))
(defun lisp-bibtex-style (lbst-file)
"Return a thunk that implements the Lisp BibTeX style of LBST-FILE."
(let ((*registered-bibtex-style* nil))
(unless (load lbst-file)
(error "Loading Lisp BibTeX style file `~A' failed."
lbst-file))
(unless *registered-bibtex-style*
(error "Lisp BibTeX style `~A' failed to register itself." lbst-file))
(cdr *registered-bibtex-style*)))
(defun find-bibtex-style (style)
"Find the named BibTeX STYLE.
* First try the styles registered using REGISTER-BIBTEX-STYLE.
* Then, if *ALLOW-LOAD-LISP-BIBTEX-STYLE* is true, try to find and
load a Lisp BibTeX style file named \"STYLE.lbst\".
* Finally try to find a BibTeX style file named \"STYLE.bst\".
Return a thunk that implements the BibTeX style. Signal an error
if no style of the requested name has been found."
(let (it)
(cond
((setq it (assoc style *bibtex-styles* :test #'string-equal))
(cdr it))
((and *allow-load-lisp-bibtex-style*
(setq it (kpathsea:find-file
(make-pathname :type "lbst" ;;:case :common
:defaults style))))
(lisp-bibtex-style it))
((setq it (kpathsea:find-file
(make-pathname :type "bst" ;;:case :common
:defaults style)))
(format *error-output* "~&The style file: ~A~%" it)
(interpreted-bibtex-style it))
(t (error "Could not find a BibTeX style named `~A'." style)))))
(defun bibtex (file-stem &key style)
"The BibTeX program. Read citation commands, a list of
bibliographic databases and the name of the bibliography style from
TeX commands in the file `FILE-STEM.aux'. Find the named bibliography
style via `find-bibtex-style'; it can be overridden programmatically
using the :STYLE argument (a string or a function designator). Print the
formatted bibliography to the file `FILE-STEM.bbl'.
Return two values, the values of *history* and *err-count*. "
(let ((*bib-macros* (make-hash-table :test #'equalp))
(*bib-database* (make-hash-table :test #'equalp))
(*bib-preamble* "")
(*bib-entries* ())
(*bib-files* ())
(*bibtex-split-initials-already-warned-hashtable* (make-hash-table :test #'equal))
(*cite-all-entries* nil)
(*cite-keys* ())
(*history* +spotless-history+)
(*err-count* 0)
(*bib-style* nil)
(*bst-functions* (builtin-bst-functions)))
(read-aux-file (make-pathname :type "aux" ;;:case :common
:defaults file-stem))
(let ((style-function
(cond
((not style) (find-bibtex-style *bib-style*))
((functionp style) style)
((symbolp style) (fdefinition style))
((stringp style) (find-bibtex-style style))
(t (error "Bad :STYLE argument: ~S" style)))))
(with-open-file (bbl-output (make-pathname :type "bbl" ;;:case :common
:defaults file-stem)
:direction :output
:if-exists :supersede)
(with-bbl-output (bbl-output)
(funcall style-function))))
(values *history* *err-count*)))
;;;;
#|
(defun f ()
(let ((s (open "/usr/share/texmf/bibtex/bst/base/abbrv.bst"))
(*bibtex-split-initials* t)
(*bst-compiling* nil)
(*bib-macros* (make-hash-table))
(*bib-database* (make-hash-table :test #'equalp))
(*bib-files* '("/home/mkoeppe/cvs/iba-papers/iba-bib.bib"))
(*cite-all-entries* t)
(*cite-keys* nil)
(*bib-entries* nil))
(get-bst-commands-and-process s)))
(let ((*readtable* *bst-readtable*))
(read s))
(let ((*readtable* *bst-readtable*))
(read-from-string "a:b"))
(defvar s (open "/tmp/x"))
(let ((*readtable* *bst-readtable*))
(read s))
(with-input-from-string (s "\"a\\ebc\"")
(read s))
(bibtex "ibm-theory")
(progn
(setf (ext:default-directory) "/home/mkoeppe/w/iba-papers/")
(let ((*lexicals* '("NUMNAMES" "NAMESLEFT" "NAMEPTR" "S" "T" "LEN" "MULTIRESULT")))
(compile-bst-file (kpathsea:find-file "amsalpha.bst")
"/tmp/compiled-bst.lisp"))
(load "/tmp/compiled-bst.lisp" :if-source-newer :compile)
(cl-bibtex "ibm-theory" 'amsalpha))
(let ((*lexicals* '("NUMNAMES" "NAMESLEFT" "NAMEPTR" "S" "T" "LEN" "MULTIRESULT")))
(compile-bst-file "/home/mkoeppe/w/diss/diss.bst"
"/tmp/compiled-bst.lisp"))
(compile-bst-file "test.bst"
"/tmp/compiled-bst.lisp")
|#