Mercurial > hg > xemacs-beta

comparison lisp/w3/dsssl.el @ 14:9ee227acff29 r19-15b90

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