14
|
1 ;;; dsssl.el --- DSSSL parser
|
|
2 ;; Author: wmperry
|
134
|
3 ;; Created: 1997/04/18 15:44:22
|
|
4 ;; Version: 1.14
|
14
|
5 ;; Keywords:
|
|
6
|
|
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
16
|
8 ;;; Copyright (c) 1996, 1997 by William M. Perry (wmperry@cs.indiana.edu)
|
|
9 ;;; Copyright (c) 1997 by Free Software Foundation, Inc.
|
14
|
10 ;;;
|
|
11 ;;; This file is part of GNU Emacs.
|
|
12 ;;;
|
|
13 ;;; GNU Emacs is free software; you can redistribute it and/or modify
|
|
14 ;;; it under the terms of the GNU General Public License as published by
|
|
15 ;;; the Free Software Foundation; either version 2, or (at your option)
|
|
16 ;;; any later version.
|
|
17 ;;;
|
|
18 ;;; GNU Emacs is distributed in the hope that it will be useful,
|
|
19 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
20 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
21 ;;; GNU General Public License for more details.
|
|
22 ;;;
|
|
23 ;;; You should have received a copy of the GNU General Public License
|
|
24 ;;; along with GNU Emacs; see the file COPYING. If not, write to the
|
|
25 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
26 ;;; Boston, MA 02111-1307, USA.
|
|
27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
28
|
|
29 (require 'cl)
|
134
|
30 (require 'dsssl-flow)
|
14
|
31
|
|
32 (if (not (fboundp 'cl-copy-hashtable))
|
|
33 (defun cl-copy-hashtable (h)
|
|
34 (let ((new (make-hash-table)))
|
|
35 (cl-maphash (function (lambda (k v) (cl-puthash k v new))) h)
|
|
36 new)))
|
|
37
|
|
38 (defconst dsssl-builtin-functions
|
|
39 '(not boolean\? case equal\? null\? list\? list length append
|
|
40 reverse list-tail list-ref member symbol\? keyword\? quantity\?
|
|
41 number\? real\? integer\? = < > <= >= + * - / max min abs quotient
|
|
42 modulo remainder floor ceiling truncate round number->string
|
|
43 string->number char\? char=\? char-property string\? string
|
|
44 string-length string-ref string=\? substring string-append
|
|
45 procedure\? apply external-procedure make time time->string quote
|
|
46 char-downcase indentity error let)
|
|
47 "A list of all the builtin DSSSL functions that we support.")
|
|
48
|
|
49 (defsubst dsssl-check-args (args expected)
|
|
50 ;; Signal an error if we don't have the expected # of arguments
|
|
51 (or (= (length args) expected)
|
|
52 (error "Wrong # arguments (expected %d): %d" expected (length args))))
|
|
53
|
|
54 (defsubst dsssl-min-args (args min)
|
|
55 (or (>= (length args) min)
|
|
56 (error "Wrong # arguments (expected at least %d): %d" min
|
|
57 (length args))))
|
|
58
|
|
59 (defun dsssl-call-function (func args)
|
|
60 (declare (special defines units))
|
|
61 (let ((old-defines nil)
|
|
62 (old-units nil)
|
|
63 (func-args (nth 1 func))
|
|
64 (real-func (nth 2 func))
|
|
65 (retval nil))
|
|
66 ;; Make sure we got the right # of arguments
|
|
67 (dsssl-check-args args (length func-args))
|
|
68
|
|
69 ;; make sure we evaluate all the arguments in the old environment
|
|
70 (setq args (mapcar 'dsssl-eval args))
|
|
71
|
|
72 ;; Save the old environment
|
|
73 (setq old-defines (cl-copy-hashtable defines)
|
|
74 old-units (cl-copy-hashtable units))
|
|
75
|
|
76 ;; Create the function's environment
|
|
77 (while func-args
|
|
78 (cl-puthash (car func-args) (car args) defines)
|
|
79 (setq func-args (cdr func-args)
|
|
80 args (cdr args)))
|
|
81
|
|
82 ;; Now evaluate the function body, returning the value of the last one
|
|
83 (while real-func
|
|
84 (setq retval (dsssl-eval (car real-func))
|
|
85 real-func (cdr real-func)))
|
|
86
|
|
87 ;; Restore the previous environment
|
|
88 (setq defines old-defines
|
|
89 units old-units)
|
|
90
|
|
91 ;; And we are out of here baby!
|
|
92 retval))
|
|
93
|
|
94 (defun dsssl-eval (form)
|
|
95 ;; We expect to have a 'defines' and 'units' hashtable floating around
|
|
96 ;; from higher up the call stack.
|
|
97 (declare (special defines units))
|
|
98 (cond
|
|
99 ((consp form) ; A function call
|
|
100 (let ((func (car form))
|
|
101 (args (cdr form)))
|
|
102 (case func
|
|
103 (cons
|
|
104 (dsssl-check-args args 2)
|
|
105 (cons (dsssl-eval (pop args)) (dsssl-eval (pop args))))
|
|
106 (cdr
|
|
107 (dsssl-check-args args 1)
|
|
108 (cdr (dsssl-eval (pop args))))
|
|
109 (car
|
|
110 (dsssl-check-args args 1)
|
|
111 (car (dsssl-eval (pop args))))
|
|
112 (not
|
|
113 (dsssl-check-args args 1)
|
|
114 (not (dsssl-eval (car args))))
|
|
115 (boolean\?
|
|
116 (dsssl-check-args args 1)
|
|
117 (and (symbolp (car args))
|
|
118 (memq (car args) '(\#f \#t))))
|
|
119 (if
|
|
120 (dsssl-min-args args 2)
|
|
121 (let ((val (dsssl-eval (pop args))))
|
|
122 (if val
|
|
123 (dsssl-eval (nth 0 args))
|
|
124 (if (nth 1 args)
|
|
125 (dsssl-eval (nth 1 args))))))
|
|
126 (let ; FIXME
|
|
127 )
|
|
128 (case
|
|
129 (dsssl-min-args args 2)
|
|
130 (let* ((val (dsssl-eval (pop args)))
|
|
131 (conditions args)
|
|
132 (done nil)
|
|
133 (possibles nil)
|
|
134 (cur nil))
|
|
135 (while (and conditions (not done))
|
|
136 (setq cur (pop conditions)
|
|
137 possibles (nth 0 cur))
|
|
138 (if (or (and (listp possibles)
|
|
139 (member val possibles))
|
|
140 (equal val possibles)
|
|
141 (memq possibles '(default otherwise)))
|
|
142 (setq done (dsssl-eval (nth 1 cur)))))
|
|
143 done))
|
|
144 (equal\?
|
|
145 (dsssl-check-args args 2)
|
|
146 (equal (dsssl-eval (car args)) (dsssl-eval (cadr args))))
|
|
147 (null\?
|
|
148 (dsssl-check-args args 1)
|
|
149 (null (dsssl-eval (car args))))
|
|
150 (list\?
|
|
151 (dsssl-check-args args 1)
|
|
152 (listp (dsssl-eval (car args))))
|
|
153 (list
|
|
154 (mapcar 'dsssl-eval args))
|
|
155 (length
|
|
156 (dsssl-check-args args 1)
|
|
157 (length (dsssl-eval (car args))))
|
|
158 (append
|
|
159 (apply 'append (mapcar 'dsssl-eval args)))
|
|
160 (reverse
|
|
161 (dsssl-check-args args 1)
|
|
162 (reverse (dsssl-eval (car args))))
|
|
163 (list-tail
|
|
164 (dsssl-check-args args 2)
|
|
165 (nthcdr (dsssl-eval (car args)) (dsssl-eval (cadr args))))
|
|
166 (list-ref
|
|
167 (dsssl-check-args args 2)
|
|
168 (nth (dsssl-eval (car args)) (dsssl-eval (cadr args))))
|
|
169 (member
|
|
170 (dsssl-check-args args 2)
|
|
171 (member (dsssl-eval (car args)) (dsssl-eval (cadr args))))
|
|
172 (symbol\?
|
|
173 (dsssl-check-args args 1)
|
|
174 (symbolp (dsssl-eval (car args))))
|
|
175 (keyword\?
|
|
176 (dsssl-check-args args 1)
|
|
177 (keywordp (dsssl-eval (car args))))
|
|
178 (quantity\?
|
|
179 (dsssl-check-args args 1)
|
|
180 (error "%s not implemented yet." func))
|
|
181 (number\?
|
|
182 (dsssl-check-args args 1)
|
|
183 (numberp (dsssl-eval (car args))))
|
|
184 (real\?
|
|
185 (dsssl-check-args args 1)
|
|
186 (let ((rval (dsssl-eval (car args))))
|
|
187 (and (numberp rval)
|
|
188 (/= (truncate rval) rval))))
|
|
189 (integer\?
|
|
190 (dsssl-check-args args 1)
|
|
191 (let ((rval (dsssl-eval (car args))))
|
|
192 (and (numberp rval)
|
|
193 (= (truncate rval) rval))))
|
|
194 ((= < > <= >=)
|
|
195 (dsssl-min-args args 2)
|
|
196 (let ((not-done t)
|
|
197 (initial (dsssl-eval (car args)))
|
|
198 (next nil))
|
|
199 (setq args (cdr args))
|
|
200 (while (and args not-done)
|
|
201 (setq next (dsssl-eval (car args))
|
|
202 args (cdr args)
|
|
203 not-done (funcall func initial next)
|
|
204 initial next))
|
|
205 not-done))
|
|
206 ((+ *)
|
|
207 (dsssl-min-args args 2)
|
|
208 (let ((acc (dsssl-eval (car args))))
|
|
209 (setq args (cdr args))
|
|
210 (while args
|
|
211 (setq acc (funcall func acc (dsssl-eval (car args)))
|
|
212 args (cdr args)))
|
|
213 acc))
|
|
214 (-
|
|
215 (dsssl-min-args args 1)
|
|
216 (apply func (mapcar 'dsssl-eval args)))
|
|
217 (/
|
|
218 (dsssl-min-args args 1)
|
|
219 (if (= (length args) 1)
|
|
220 (/ 1 (dsssl-eval (car args)))
|
|
221 (apply func (mapcar 'dsssl-eval args))))
|
|
222 ((max min)
|
|
223 (apply func (mapcar 'dsssl-eval args)))
|
|
224 (abs
|
|
225 (dsssl-check-args args 1)
|
|
226 (abs (dsssl-eval (car args))))
|
|
227 (quotient ; FIXME
|
|
228 (error "`%s' not implemented yet!" func))
|
|
229 (modulo
|
|
230 (dsssl-check-args args 2)
|
|
231 (mod (dsssl-eval (car args)) (dsssl-eval (cadr args))))
|
|
232 (remainder
|
|
233 (dsssl-check-args args 2)
|
|
234 (% (dsssl-eval (car args)) (dsssl-eval (cadr args))))
|
|
235 ((floor ceiling truncate round)
|
|
236 (dsssl-check-args args 1)
|
|
237 (funcall func (dsssl-eval (car args))))
|
|
238 (number->string
|
|
239 (dsssl-min-args args 1)
|
|
240 (if (= (length args) 1)
|
|
241 (number-to-string (dsssl-eval (car args)))
|
|
242 (if (= (length args) 2) ; They gave us a radix
|
|
243 (error "Radix arg not supported yet.")
|
|
244 (dsssl-check-args args 1))))
|
|
245 (string->number
|
|
246 (dsssl-min-args args 1)
|
|
247 (if (= (length args) 1)
|
|
248 (string-to-number (dsssl-eval (car args)))
|
|
249 (if (= (length args) 2) ; They gave us a radix
|
|
250 (error "Radix arg not supported yet.")
|
|
251 (dsssl-check-args args 1))))
|
|
252 (char\?
|
|
253 (dsssl-check-args args 1)
|
|
254 (characterp (dsssl-eval (car args))))
|
|
255 (char=\?
|
|
256 (dsssl-check-args args 2)
|
|
257 (char-equal (dsssl-eval (car args)) (dsssl-eval (cadr args))))
|
|
258 (char-downcase
|
|
259 (dsssl-check-args args 1)
|
|
260 (downcase (dsssl-eval (car args))))
|
|
261 (char-property ; FIXME
|
|
262 (error "`%s' not implemented yet!" func))
|
|
263 (string\?
|
|
264 (dsssl-check-args args 1)
|
|
265 (stringp (dsssl-eval (car args))))
|
|
266 (string
|
|
267 (dsssl-min-args args 1)
|
|
268 (mapconcat 'char-to-string (mapcar 'dsssl-eval args) ""))
|
|
269 (string-length
|
|
270 (dsssl-check-args args 1)
|
|
271 (length (dsssl-eval (car args))))
|
|
272 (string-ref
|
|
273 (dsssl-check-args args 2)
|
|
274 (aref (dsssl-eval (car args)) (dsssl-eval (cadr args))))
|
|
275 (string=\?
|
|
276 (dsssl-check-args args 2)
|
|
277 (string= (dsssl-eval (car args)) (dsssl-eval (cadr args))))
|
|
278 (substring
|
|
279 (substring (dsssl-eval (pop args))
|
|
280 (dsssl-eval (pop args))
|
|
281 (dsssl-eval (pop args))))
|
|
282 (string-append
|
|
283 (let ((rval ""))
|
|
284 (while args
|
|
285 (setq rval (concat rval (dsssl-eval (pop args)))))
|
|
286 rval))
|
|
287 (procedure\?
|
|
288 (dsssl-check-args args 1)
|
|
289 (let* ((sym (dsssl-eval (car args)))
|
|
290 (def (cl-gethash sym defines)))
|
|
291 (or (memq sym dsssl-builtin-functions)
|
|
292 (and def (listp def) (eq (car def) 'lambda)))))
|
|
293 (apply ; FIXME
|
|
294 )
|
|
295 (external-procedure ; FIXME
|
|
296 )
|
|
297 (make
|
|
298 (let* ((type (dsssl-eval (pop args)))
|
|
299 (symname nil)
|
|
300 (props nil)
|
|
301 (tail nil)
|
|
302 (children nil)
|
|
303 (temp nil)
|
|
304 )
|
|
305 ;; Massage :children into the last slot
|
|
306 (setq props (mapcar 'dsssl-eval args)
|
|
307 tail (last props)
|
|
308 children (car tail))
|
|
309 (if (consp tail)
|
|
310 (setcar tail nil))
|
|
311 (if (not (car props))
|
|
312 (setq props nil))
|
|
313 (setq temp (- (length props) 1))
|
|
314 ;; Not sure if we should really bother with this or not, but
|
|
315 ;; it does at least make it look more common-lispy keywordish
|
|
316 ;; and such. DSSSL keywords look like font-weight:, this makes
|
|
317 ;; it :font-weight
|
|
318 (while (>= temp 0)
|
|
319 (setq symname (symbol-name (nth temp props)))
|
|
320 (if (string-match "^\\(.*\\):$" symname)
|
|
321 (setf (nth temp props)
|
|
322 (intern (concat ":" (match-string 1 symname)))))
|
|
323 (setq temp (- temp 2)))
|
|
324
|
|
325 ;; Create the actual flow object
|
134
|
326 (make-flow-object :type type
|
14
|
327 :children children
|
|
328 :properties props)
|
|
329 )
|
|
330 )
|
|
331 (time
|
|
332 (mapconcat 'int-to-string (current-time) ":"))
|
|
333 (time->string
|
|
334 (dsssl-check-args args 1)
|
|
335 (current-time-string
|
|
336 (mapcar 'string-to-int
|
|
337 (split-string (dsssl-eval (car args)) ":"))))
|
|
338 (quote
|
|
339 (dsssl-check-args args 1)
|
|
340 (car args))
|
|
341 (identity
|
|
342 (dsssl-check-args args 1)
|
|
343 (dsssl-eval (car args)))
|
|
344 (error
|
|
345 (apply 'error (mapcar 'dsssl-eval args)))
|
|
346 (otherwise
|
|
347 ;; A non-built-in function - look it up
|
|
348 (let ((def (cl-gethash func defines)))
|
|
349 (if (and def (listp def) (eq (car def) 'lambda))
|
|
350 (dsssl-call-function def args)
|
|
351 (error "Symbol's function definition is void: %s" func))))
|
|
352 )
|
|
353 )
|
|
354 )
|
|
355 ((symbolp form) ; A variable
|
|
356 ;; A DSSSL keyword!
|
|
357 (if (string-match ":$" (symbol-name form))
|
|
358 form
|
|
359 (let ((val (cl-gethash form defines 'ThIS-Is_A_BOgUs-VariuhhBBLE)))
|
|
360 (if (not (eq val 'ThIS-Is_A_BOgUs-VariuhhBBLE))
|
|
361 val
|
|
362 ;; Ok, we got a bogus variable, but maybe it is really a UNIT
|
|
363 ;; dereference. Check.
|
|
364 (let ((name (symbol-name form))
|
|
365 (the-units nil)
|
|
366 (number nil)
|
|
367 (conversion nil))
|
|
368 (if (not (string-match "^\\([0-9.]+\\)\\([a-zA-Z]+\\)$" name))
|
|
369 (error "Symbol's value as variable is void: %s" form)
|
|
370 (setq number (string-to-int (match-string 1 name))
|
|
371 the-units (intern (downcase (match-string 2 name)))
|
|
372 conversion (cl-gethash the-units units))
|
|
373 (if (or (not conversion) (not (numberp conversion)))
|
|
374 (error "Symbol's value as variable is void: %s" form)
|
|
375 (* number conversion))))))))
|
|
376 (t
|
|
377 form)
|
|
378 )
|
|
379 )
|
|
380
|
|
381 (defsubst dsssl-predeclared ()
|
|
382 (declare (special defines units))
|
|
383 (cl-puthash '\#f nil defines)
|
|
384 (cl-puthash 'nil nil defines)
|
|
385 (cl-puthash '\#t t defines)
|
|
386 ;; NOTE: All units are stored internally as points.
|
|
387 (cl-puthash 'in (float 72) units)
|
|
388 (cl-puthash 'mm (float (* 72 25.4)) units)
|
|
389 (cl-puthash 'cm (float (* 72 2.54)) units)
|
|
390 )
|
|
391
|
|
392 (defun dsssl-parse (buf)
|
|
393 ;; Return the full representation of the DSSSL stylesheet as a series
|
|
394 ;; of LISP objects.
|
|
395 (let ((defines (make-hash-table :size 13))
|
|
396 (units (make-hash-table :size 13))
|
|
397 (buf-contents nil))
|
|
398 (dsssl-predeclared)
|
|
399 (save-excursion
|
|
400 (setq buf-contents (if (or (bufferp buf) (get-buffer buf))
|
|
401 (progn
|
|
402 (set-buffer buf)
|
|
403 (buffer-string))
|
|
404 buf))
|
|
405 (set-buffer (generate-new-buffer " *dsssl-style*"))
|
|
406 (insert buf-contents)
|
|
407 (goto-char (point-min))
|
|
408 (skip-chars-forward " \t\n\r")
|
|
409 (if (looking-at "<!") ; DOCTYPE present
|
|
410 (progn
|
|
411 ;; This should _DEFINITELY_ be smarter
|
|
412 (search-forward ">" nil t)
|
|
413 ))
|
|
414 (let ((result nil)
|
|
415 (temp nil)
|
|
416 (save-pos nil))
|
|
417 (while (not (eobp))
|
|
418 (condition-case ()
|
|
419 (setq save-pos (point)
|
|
420 temp (read (current-buffer)))
|
|
421 (invalid-read-syntax
|
|
422 ;; This disgusting hack is in here so that we can basically
|
|
423 ;; extend the lisp reader to gracefully deal with converting
|
|
424 ;; DSSSL #\A to Emacs-Lisp ?A notation. If you know of a
|
|
425 ;; better way, please feel free to send me some email.
|
|
426 (setq temp nil)
|
|
427 (backward-char 1)
|
|
428 (if (looking-at "#\\\\")
|
|
429 (replace-match "?")
|
|
430 (insert "\\"))
|
|
431 (goto-char save-pos))
|
|
432 (error nil))
|
|
433 (cond
|
|
434 ((null temp)
|
|
435 nil)
|
|
436 ((listp temp)
|
|
437 (case (car temp)
|
|
438 (define-unit
|
|
439 (cl-puthash (cadr temp) (dsssl-eval (caddr temp))
|
|
440 units))
|
|
441 (define
|
|
442 (if (listp (cadr temp))
|
|
443 ;; A function
|
|
444 (cl-puthash (caadr temp)
|
|
445 (list 'lambda
|
|
446 (cdadr temp)
|
|
447 (cddr temp)) defines)
|
|
448 ;; A normal define
|
|
449 (cl-puthash (cadr temp)
|
|
450 (dsssl-eval (caddr temp)) defines)))
|
|
451 (otherwise
|
|
452 (setq result (cons temp result)))))
|
|
453 (t
|
|
454 (setq result (cons temp result))))
|
|
455 (skip-chars-forward " \t\n\r"))
|
|
456 (kill-buffer (current-buffer))
|
|
457 (list defines units (nreverse result))))))
|
|
458
|
|
459 (defun dsssl-test (x)
|
|
460 (let* ((result (dsssl-parse x))
|
|
461 (defines (nth 0 result))
|
|
462 (units (nth 1 result))
|
|
463 (forms (nth 2 result)))
|
|
464 (mapcar 'dsssl-eval forms)))
|
|
465
|
|
466
|
|
467 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
468 ;;; The flow object classes.
|
|
469 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
470 (defmacro flow-object-property (obj prop &optional default)
|
|
471 "Return property PROP of the DSSSL flow object OBJ.
|
|
472 OBJ can be any flow object class, as long as it was properly derived
|
|
473 from the base `flow-object' class."
|
|
474 (` (plist-get (flow-object-properties (, obj)) (, prop) (, default))))
|
|
475
|
|
476 ;; Now for specific types of flow objects
|
|
477 ;; Still to do:
|
|
478 ;;; display-group
|
|
479 ;;; paragraph
|
|
480 ;;; sequence
|
|
481 ;;; line-field
|
|
482 ;;; paragraph-break
|
|
483 ;;; simple-page-sequence
|
|
484 ;;; score
|
|
485 ;;; table
|
|
486 ;;; table-row
|
|
487 ;;; table-cell
|
|
488 ;;; rule
|
|
489 ;;; external-graphic
|
|
490
|
|
491
|
|
492 (provide 'dsssl)
|