cgit.sxemacs.org Git - packages/blob - xemacs-packages/w3/lisp/dsssl.el

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