зеркало из https://github.com/mozilla/pjs.git
Added :semantic-comment and :vector-construct.
This commit is contained in:
waldemar%netscape.com
Родитель
ddf1704526
Коммит
17b22162c1
|
|
@ -1,678 +0,0 @@
|
|||
;;; The contents of this file are subject to the Mozilla Public
|
||||
;;; License Version 1.1 (the "License"); you may not use this file
|
||||
;;; except in compliance with the License. You may obtain a copy of
|
||||
;;; the License at http://www.mozilla.org/MPL/
|
||||
;;;
|
||||
;;; Software distributed under the License is distributed on an "AS
|
||||
;;; IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
|
||||
;;; implied. See the License for the specific language governing
|
||||
;;; rights and limitations under the License.
|
||||
;;;
|
||||
;;; The Original Code is the Language Design and Prototyping Environment.
|
||||
;;;
|
||||
;;; The Initial Developer of the Original Code is Netscape Communications
|
||||
;;; Corporation. Portions created by Netscape Communications Corporation are
|
||||
;;; Copyright (C) 1999 Netscape Communications Corporation. All
|
||||
;;; Rights Reserved.
|
||||
;;;
|
||||
;;; Contributor(s): Waldemar Horwat <waldemar@acm.org>
|
||||
|
||||
;;;
|
||||
;;; HTML output generator
|
||||
;;;
|
||||
;;; Waldemar Horwat (waldemar@acm.org)
|
||||
;;;
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; ELEMENTS
|
||||
|
||||
(defstruct (html-element (:constructor make-html-element (name self-closing indent
|
||||
newlines-before newlines-begin newlines-end newlines-after))
|
||||
(:predicate html-element?))
|
||||
(name nil :type symbol :read-only t) ;Name of the tag
|
||||
(self-closing nil :type bool :read-only t) ;True if the closing tag should be omitted
|
||||
(indent nil :type integer :read-only t) ;Number of spaces by which to indent this tag's contents in HTML source
|
||||
(newlines-before nil :type integer :read-only t) ;Number of HTML source newlines preceding the opening tag
|
||||
(newlines-begin nil :type integer :read-only t) ;Number of HTML source newlines immediately following the opening tag
|
||||
(newlines-end nil :type integer :read-only t) ;Number of HTML source newlines immediately preceding the closing tag
|
||||
(newlines-after nil :type integer :read-only t)) ;Number of HTML source newlines following the closing tag
|
||||
|
||||
|
||||
; Define symbol to refer to the given html-element.
|
||||
(defun define-html (symbol newlines-before newlines-begin newlines-end newlines-after &key self-closing (indent 0))
|
||||
(setf (get symbol 'html-element) (make-html-element symbol self-closing indent
|
||||
newlines-before newlines-begin newlines-end newlines-after)))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; ELEMENT DEFINITIONS
|
||||
|
||||
(define-html 'a 0 0 0 0)
|
||||
(define-html 'b 0 0 0 0)
|
||||
(define-html 'blockquote 1 0 0 1 :indent 2)
|
||||
(define-html 'body 1 1 1 1)
|
||||
(define-html 'br 0 0 0 1 :self-closing t)
|
||||
(define-html 'code 0 0 0 0)
|
||||
(define-html 'dd 1 0 0 1 :indent 2)
|
||||
(define-html 'del 0 0 0 0)
|
||||
(define-html 'div 1 0 0 1 :indent 2)
|
||||
(define-html 'dl 1 0 0 2 :indent 2)
|
||||
(define-html 'dt 1 0 0 1 :indent 2)
|
||||
(define-html 'em 0 0 0 0)
|
||||
(define-html 'h1 2 0 0 2 :indent 2)
|
||||
(define-html 'h2 2 0 0 2 :indent 2)
|
||||
(define-html 'h3 2 0 0 2 :indent 2)
|
||||
(define-html 'h4 1 0 0 2 :indent 2)
|
||||
(define-html 'h5 1 0 0 2 :indent 2)
|
||||
(define-html 'h6 1 0 0 2 :indent 2)
|
||||
(define-html 'head 1 1 1 2)
|
||||
(define-html 'hr 1 0 0 1 :self-closing t)
|
||||
(define-html 'html 0 1 1 1)
|
||||
(define-html 'i 0 0 0 0)
|
||||
(define-html 'li 1 0 0 1 :indent 2)
|
||||
(define-html 'link 1 0 0 1 :self-closing t)
|
||||
(define-html 'ol 1 1 1 2 :indent 2)
|
||||
(define-html 'p 1 0 0 2)
|
||||
(define-html 'script 0 0 0 0)
|
||||
(define-html 'span 0 0 0 0)
|
||||
(define-html 'strong 0 0 0 0)
|
||||
(define-html 'sub 0 0 0 0)
|
||||
(define-html 'sup 0 0 0 0)
|
||||
(define-html 'table 1 1 1 2)
|
||||
(define-html 'td 1 0 0 1 :indent 2)
|
||||
(define-html 'th 1 0 0 1 :indent 2)
|
||||
(define-html 'title 1 0 0 1)
|
||||
(define-html 'tr 1 0 0 1 :indent 2)
|
||||
(define-html 'u 0 0 0 0)
|
||||
(define-html 'ul 1 1 1 2 :indent 2)
|
||||
(define-html 'var 0 0 0 0)
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; ATTRIBUTES
|
||||
|
||||
;;; The following element attributes require their values to always be in quotes.
|
||||
(dolist (attribute '(alt href name))
|
||||
(setf (get attribute 'quoted-attribute) t))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; ENTITIES
|
||||
|
||||
(defvar *html-entities-list*
|
||||
'((#\& . "amp")
|
||||
(#\" . "quot")
|
||||
(#\< . "lt")
|
||||
(#\> . "gt")
|
||||
(nbsp . "nbsp")))
|
||||
|
||||
(defvar *html-entities-hash* (make-hash-table))
|
||||
|
||||
(dolist (entity-binding *html-entities-list*)
|
||||
(setf (gethash (first entity-binding) *html-entities-hash*) (rest entity-binding)))
|
||||
|
||||
|
||||
; Return a freshly consed list of <html-source> that represent the characters in the string except that
|
||||
; '&', '<', and '>' are replaced by their entities and spaces are replaced by the entity
|
||||
; given by the space parameter (which should be either 'space or 'nbsp).
|
||||
(defun escape-html-characters (string space)
|
||||
(let ((html-sources nil))
|
||||
(labels
|
||||
((escape-remainder (start)
|
||||
(let ((i (position-if #'(lambda (char) (member char '(#\& #\< #\> #\space))) string :start start)))
|
||||
(if i
|
||||
(let ((char (char string i)))
|
||||
(unless (= i start)
|
||||
(push (subseq string start i) html-sources))
|
||||
(push (if (eql char #\space) space char) html-sources)
|
||||
(escape-remainder (1+ i)))
|
||||
(push (if (zerop start) string (subseq string start)) html-sources)))))
|
||||
(unless (zerop (length string))
|
||||
(escape-remainder 0))
|
||||
(nreverse html-sources))))
|
||||
|
||||
|
||||
; Escape all content strings in the html-source, while interpreting :nowrap, :wrap, and :none pseudo-tags.
|
||||
; Return a freshly consed list of html-sources.
|
||||
(defun escape-html-source (html-source space)
|
||||
(cond
|
||||
((stringp html-source)
|
||||
(escape-html-characters html-source space))
|
||||
((or (characterp html-source) (symbolp html-source) (integerp html-source))
|
||||
(list html-source))
|
||||
((consp html-source)
|
||||
(let ((tag (first html-source))
|
||||
(contents (rest html-source)))
|
||||
(case tag
|
||||
(:none (mapcan #'(lambda (html-source) (escape-html-source html-source space)) contents))
|
||||
(:nowrap (mapcan #'(lambda (html-source) (escape-html-source html-source 'nbsp)) contents))
|
||||
(:wrap (mapcan #'(lambda (html-source) (escape-html-source html-source 'space)) contents))
|
||||
(t (list (cons tag
|
||||
(mapcan #'(lambda (html-source) (escape-html-source html-source space)) contents)))))))
|
||||
(t (error "Bad html-source: ~S" html-source))))
|
||||
|
||||
|
||||
; Escape all content strings in the html-source, while interpreting :nowrap, :wrap, and :none pseudo-tags.
|
||||
(defun escape-html (html-source)
|
||||
(let ((results (escape-html-source html-source 'space)))
|
||||
(assert-true (= (length results) 1))
|
||||
(first results)))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; HTML WRITER
|
||||
|
||||
;; <html-source> has one of the following formats:
|
||||
;; <string> ;String to be printed literally
|
||||
;; <symbol> ;Named entity
|
||||
;; <integer> ;Numbered entity
|
||||
;; space ;Space or newline
|
||||
;; (<tag> <html-source> ... <html-source>) ;Tag and its contents
|
||||
;; ((:nest <tag> ... <tag>) <html-source> ... <html-source>) ;Equivalent to (<tag> (... (<tag> <html-source> ... <html-source>)))
|
||||
;;
|
||||
;; <tag> has one of the following formats:
|
||||
;; <symbol> ;Tag with no attributes
|
||||
;; (<symbol> <attribute> ... <attribute>) ;Tag with attributes
|
||||
;; :nowrap ;Pseudo-tag indicating that spaces in contents should be non-breaking
|
||||
;; :wrap ;Pseudo-tag indicating that spaces in contents should be breaking
|
||||
;; :none ;Pseudo-tag indicating no tag -- the contents should be inlined
|
||||
;;
|
||||
;; <attribute> has one of the following formats:
|
||||
;; (<symbol> <string>) ;Attribute name and value
|
||||
;; (<symbol>) ;Attribute name with omitted value
|
||||
|
||||
|
||||
(defparameter *html-right-margin* 100)
|
||||
(defparameter *allow-line-breaks-in-tags* nil) ;Allow line breaks in tags between attributes?
|
||||
|
||||
(defvar *current-html-pos*) ;Number of characters written to the current line of the stream; nil if *current-html-newlines* is nonzero
|
||||
(defvar *current-html-pending*) ;String following a space or newline pending to be printed on the current line or nil if none
|
||||
(defvar *current-html-indent*) ;Indent to use for emit-html-newlines-and-indent calls
|
||||
(defvar *current-html-newlines*) ;Number of consecutive newlines just written to the stream; zero if last character wasn't a newline
|
||||
|
||||
|
||||
; Flush *current-html-pending* onto the stream.
|
||||
(defun flush-current-html-pending (stream)
|
||||
(when *current-html-pending*
|
||||
(unless (zerop (length *current-html-pending*))
|
||||
(write-char #\space stream)
|
||||
(write-string *current-html-pending* stream)
|
||||
(incf *current-html-pos* (1+ (length *current-html-pending*))))
|
||||
(setq *current-html-pending* nil)))
|
||||
|
||||
|
||||
; Emit n-newlines onto the stream and indent the next line by *current-html-indent* spaces.
|
||||
(defun emit-html-newlines-and-indent (stream n-newlines)
|
||||
(decf n-newlines *current-html-newlines*)
|
||||
(when (plusp n-newlines)
|
||||
(flush-current-html-pending stream)
|
||||
(dotimes (i n-newlines)
|
||||
(write-char #\newline stream))
|
||||
(incf *current-html-newlines* n-newlines)
|
||||
(setq *current-html-pos* nil)))
|
||||
|
||||
|
||||
; Write the string to the stream, observing *current-html-pending* and *current-html-pos*.
|
||||
(defun write-html-string (stream html-string)
|
||||
(unless (zerop (length html-string))
|
||||
(unless *current-html-pos*
|
||||
(setq *current-html-newlines* 0)
|
||||
(write-string (make-string *current-html-indent* :initial-element #\space) stream)
|
||||
(setq *current-html-pos* *current-html-indent*))
|
||||
(if *current-html-pending*
|
||||
(progn
|
||||
(setq *current-html-pending* (if (zerop (length *current-html-pending*))
|
||||
html-string
|
||||
(concatenate 'string *current-html-pending* html-string)))
|
||||
(when (>= (+ *current-html-pos* (length *current-html-pending*)) *html-right-margin*)
|
||||
(write-char #\newline stream)
|
||||
(write-string *current-html-pending* stream)
|
||||
(setq *current-html-pos* (length *current-html-pending*))
|
||||
(setq *current-html-pending* nil)))
|
||||
(progn
|
||||
(write-string html-string stream)
|
||||
(incf *current-html-pos* (length html-string))))))
|
||||
|
||||
|
||||
; Return true if the value string contains a character that would require an attribute to be quoted.
|
||||
; For convenience, this returns true if value contains a period, even though strictly speaking periods do
|
||||
; not force quoting.
|
||||
(defun attribute-value-needs-quotes (value)
|
||||
(dotimes (i (length value) nil)
|
||||
(let ((ch (char value i)))
|
||||
(unless (or (char<= #\0 ch #\9) (char<= #\A ch #\Z) (char<= #\a ch #\z) (char= ch #\-))
|
||||
(return t)))))
|
||||
|
||||
|
||||
; Emit the html tag with the given tag-symbol (name), attributes, and contents.
|
||||
(defun write-html-tag (stream tag-symbol attributes contents)
|
||||
(let ((element (assert-non-null (get tag-symbol 'html-element))))
|
||||
(emit-html-newlines-and-indent stream (html-element-newlines-before element))
|
||||
(write-html-string stream (format nil "<~A" (html-element-name element)))
|
||||
(let ((*current-html-indent* (+ *current-html-indent* (html-element-indent element))))
|
||||
(dolist (attribute attributes)
|
||||
(let ((name (first attribute))
|
||||
(value (second attribute)))
|
||||
(write-html-source stream (if *allow-line-breaks-in-tags* 'space #\space))
|
||||
(write-html-string stream (string-downcase (symbol-name name)))
|
||||
(when value
|
||||
(write-html-string
|
||||
stream
|
||||
(format nil
|
||||
(if (or (attribute-value-needs-quotes value)
|
||||
(get name 'quoted-attribute))
|
||||
"=\"~A\""
|
||||
"=~A")
|
||||
value)))))
|
||||
(write-html-string stream ">")
|
||||
(emit-html-newlines-and-indent stream (html-element-newlines-begin element))
|
||||
(dolist (html-source contents)
|
||||
(write-html-source stream html-source)))
|
||||
(unless (html-element-self-closing element)
|
||||
(emit-html-newlines-and-indent stream (html-element-newlines-end element))
|
||||
(write-html-string stream (format nil "</~A>" (html-element-name element))))
|
||||
(emit-html-newlines-and-indent stream (html-element-newlines-after element))))
|
||||
|
||||
|
||||
; Write html-source to the character stream.
|
||||
(defun write-html-source (stream html-source)
|
||||
(cond
|
||||
((stringp html-source)
|
||||
(write-html-string stream html-source))
|
||||
((eq html-source 'space)
|
||||
(when (zerop *current-html-newlines*)
|
||||
(flush-current-html-pending stream)
|
||||
(setq *current-html-pending* "")))
|
||||
((or (characterp html-source) (symbolp html-source))
|
||||
(let ((entity-name (gethash html-source *html-entities-hash*)))
|
||||
(cond
|
||||
(entity-name
|
||||
(write-html-string stream (format nil "&~A;" entity-name)))
|
||||
((characterp html-source)
|
||||
(write-html-string stream (string html-source)))
|
||||
(t (error "Bad html-source ~S" html-source)))))
|
||||
((integerp html-source)
|
||||
(assert-true (and (>= html-source 0) (< html-source 65536)))
|
||||
(write-html-string stream (format nil "&#~D;" html-source)))
|
||||
((consp html-source)
|
||||
(let ((tag (first html-source))
|
||||
(contents (rest html-source)))
|
||||
(if (consp tag)
|
||||
(write-html-tag stream (first tag) (rest tag) contents)
|
||||
(write-html-tag stream tag nil contents))))
|
||||
(t (error "Bad html-source: ~S" html-source))))
|
||||
|
||||
|
||||
; Write the top-level html-source to the character stream.
|
||||
(defun write-html (html-source &optional (stream t))
|
||||
(with-standard-io-syntax
|
||||
(let ((*print-readably* nil)
|
||||
(*print-escape* nil)
|
||||
(*print-case* :upcase)
|
||||
(*current-html-pos* nil)
|
||||
(*current-html-pending* nil)
|
||||
(*current-html-indent* 0)
|
||||
(*current-html-newlines* 9999))
|
||||
(write-string "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0 Transitional//EN\" \"http://www.w3.org/TR/REC-html40/loose.dtd\">" stream)
|
||||
(write-char #\newline stream)
|
||||
(write-html-source stream (escape-html html-source)))))
|
||||
|
||||
|
||||
; Write html to the text file with the given name (relative to the
|
||||
; local directory).
|
||||
(defun write-html-to-local-file (filename html)
|
||||
(with-open-file (stream (filename-to-semantic-engine-pathname filename)
|
||||
:direction :output
|
||||
:if-exists :supersede
|
||||
#+mcl :mac-file-creator #+mcl "MOSS")
|
||||
(write-html html stream)))
|
||||
|
||||
|
||||
; Expand the :nest constructs inside html-source.
|
||||
(defun unnest-html-source (html-source)
|
||||
(labels
|
||||
((unnest-tags (tags contents)
|
||||
(assert-true tags)
|
||||
(cons (first tags)
|
||||
(if (endp (rest tags))
|
||||
contents
|
||||
(list (unnest-tags (rest tags) contents))))))
|
||||
(if (consp html-source)
|
||||
(let ((tag (first html-source))
|
||||
(contents (rest html-source)))
|
||||
(if (and (consp tag) (eq (first tag) ':nest))
|
||||
(unnest-html-source (unnest-tags (rest tag) contents))
|
||||
(cons tag (mapcar #'unnest-html-source contents))))
|
||||
html-source)))
|
||||
|
||||
|
||||
; Coalesce an A element immediately containing or contained in a SPAN element into one if their attributes
|
||||
; are disjoint. Also coalesce SUB and SUP elements immediately containing SPAN elements into one.
|
||||
(defun coalesce-elements (html-source)
|
||||
(if (consp html-source)
|
||||
(let ((tag (first html-source))
|
||||
(contents (mapcar #'coalesce-elements (rest html-source))))
|
||||
(cond
|
||||
((and (consp tag)
|
||||
(member (first tag) '(a span))
|
||||
contents
|
||||
(null (cdr contents))
|
||||
(consp (car contents))
|
||||
(let ((tag2 (caar contents)))
|
||||
(and (consp tag2)
|
||||
(member (first tag2) '(a span))
|
||||
(not (eq tag tag2))
|
||||
(null (intersection (rest tag) (rest tag2) :key #'car)))))
|
||||
(cons
|
||||
(cons 'a
|
||||
(if (eq (first tag) 'a)
|
||||
(append (rest tag) (rest (caar contents)))
|
||||
(append (rest (caar contents)) (rest tag))))
|
||||
(cdar contents)))
|
||||
((and (member tag '(sub sup))
|
||||
contents
|
||||
(null (cdr contents))
|
||||
(consp (car contents))
|
||||
(consp (caar contents))
|
||||
(eq (caaar contents) 'span))
|
||||
(cons
|
||||
(cons tag (rest (caar contents)))
|
||||
(cdar contents)))
|
||||
(t (cons tag contents))))
|
||||
html-source))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; HTML MAPPINGS
|
||||
|
||||
(defparameter *html-definitions*
|
||||
'(((:new-line t) (br))
|
||||
|
||||
;Misc.
|
||||
(:spc nbsp)
|
||||
(:tab2 nbsp nbsp)
|
||||
(:tab3 nbsp nbsp nbsp)
|
||||
(:nbhy "-") ;Non-breaking hyphen
|
||||
|
||||
;Symbols (-10 suffix means 10-point, etc.)
|
||||
((:bullet 1) (:script "document.write(U_bull)")) ;#x2022
|
||||
((:minus 1) "-")
|
||||
((:not-equal 1) (:script "document.write(U_ne)")) ;#x2260
|
||||
((:less-or-equal 1) (:script "document.write(U_le)")) ;#x2264
|
||||
((:greater-or-equal 1) (:script "document.write(U_ge)")) ;#x2265
|
||||
((:infinity 1) (:script "document.write(U_infin)")) ;#x221E
|
||||
((:left-single-quote 1) #x2018)
|
||||
((:right-single-quote 1) #x2019)
|
||||
((:left-double-quote 1) #x201C)
|
||||
((:right-double-quote 1) #x201D)
|
||||
((:left-angle-quote 1) #x00AB)
|
||||
((:right-angle-quote 1) #x00BB)
|
||||
((:bottom-10 1) (:script "document.write(U_perp)")) ;#x22A5
|
||||
((:vector-assign-10 1) (:script "document.write(U_larr)")) ;#x2190
|
||||
((:up-arrow-10 1) (:script "document.write(U_uarr)")) ;#x2191
|
||||
((:function-arrow-10 2) (:script "document.write(U_rarr)")) ;#x2192
|
||||
((:cartesian-product-10 2) (:script "document.write(U_times)")) ;#x00D7
|
||||
((:identical-10 2) (:script "document.write(U_equiv)")) ;#x2261
|
||||
((:circle-plus-10 2) (:script "document.write(U_oplus)")) ;#x2295
|
||||
((:empty-10 2) (:script "document.write(U_empty)")) ;#x2205
|
||||
((:intersection-10 1) (:script "document.write(U_cap)")) ;#x2229
|
||||
((:union-10 1) (:script "document.write(U_cup)")) ;#x222A
|
||||
((:member-10 2) (:script "document.write(U_isin)")) ;#x2208
|
||||
((:not-member-10 2) (:script "document.write(U_notin)")) ;#x2209
|
||||
((:derives-10 2) (:script "document.write(U_rArr)")) ;#x21D2
|
||||
((:left-triangle-bracket-10 1) (:script "document.write(U_lang)")) ;#x2329
|
||||
((:right-triangle-bracket-10 1) (:script "document.write(U_rang)")) ;#x232A
|
||||
|
||||
((:alpha 1) (:script "document.write(U_alpha)"))
|
||||
((:beta 1) (:script "document.write(U_beta)"))
|
||||
((:chi 1) (:script "document.write(U_chi)"))
|
||||
((:delta 1) (:script "document.write(U_delta)"))
|
||||
((:epsilon 1) (:script "document.write(U_epsilon)"))
|
||||
((:phi 1) (:script "document.write(U_phi)"))
|
||||
((:gamma 1) (:script "document.write(U_gamma)"))
|
||||
((:eta 1) (:script "document.write(U_eta)"))
|
||||
((:iota 1) (:script "document.write(U_iota)"))
|
||||
((:kappa 1) (:script "document.write(U_kappa)"))
|
||||
((:lambda 1) (:script "document.write(U_lambda)"))
|
||||
((:mu 1) (:script "document.write(U_mu)"))
|
||||
((:nu 1) (:script "document.write(U_nu)"))
|
||||
((:omicron 1) (:script "document.write(U_omicron)"))
|
||||
((:pi 1) (:script "document.write(U_pi)"))
|
||||
((:theta 1) (:script "document.write(U_theta)"))
|
||||
((:rho 1) (:script "document.write(U_rho)"))
|
||||
((:sigma 1) (:script "document.write(U_sigma)"))
|
||||
((:tau 1) (:script "document.write(U_tau)"))
|
||||
((:upsilon 1) (:script "document.write(U_upsilon)"))
|
||||
((:omega 1) (:script "document.write(U_omega)"))
|
||||
((:xi 1) (:script "document.write(U_xi)"))
|
||||
((:psi 1) (:script "document.write(U_psi)"))
|
||||
((:zeta 1) (:script "document.write(U_zeta)"))
|
||||
|
||||
;Block Styles
|
||||
(:js2 (div (class "js2")))
|
||||
(:es4 (div (class "es4")))
|
||||
(:body-text p)
|
||||
(:section-heading h2)
|
||||
(:subsection-heading h3)
|
||||
(:grammar-header h4)
|
||||
(:grammar-rule (:nest :nowrap (div (class "grammar-rule"))))
|
||||
(:grammar-lhs (:nest :nowrap (div (class "grammar-lhs"))))
|
||||
(:grammar-lhs-last :grammar-lhs)
|
||||
(:grammar-rhs (:nest :nowrap (div (class "grammar-rhs"))))
|
||||
(:grammar-rhs-last :grammar-rhs)
|
||||
(:grammar-argument (:nest :nowrap (div (class "grammar-argument"))))
|
||||
(:semantics (:nest :nowrap (p (class "semantics"))))
|
||||
(:semantics-next (:nest :nowrap (p (class "semantics-next"))))
|
||||
|
||||
;Inline Styles
|
||||
(:script (script (type "text/javascript")))
|
||||
(:symbol (span (class "symbol")))
|
||||
(:character-literal code)
|
||||
(:character-literal-control (span (class "control")))
|
||||
(:terminal (span (class "terminal")))
|
||||
(:terminal-keyword (code (class "terminal-keyword")))
|
||||
(:nonterminal (span (class "nonterminal")))
|
||||
(:nonterminal-attribute (span (class "nonterminal-attribute")))
|
||||
(:nonterminal-argument (span (class "nonterminal-argument")))
|
||||
(:semantic-keyword (span (class "semantic-keyword")))
|
||||
(:type-expression (span (class "type-expression")))
|
||||
(:type-name (span (class "type-name")))
|
||||
(:field-name (span (class "field-name")))
|
||||
(:global-variable (span (class "global-variable")))
|
||||
(:local-variable (span (class "local-variable")))
|
||||
(:action-name (span (class "action-name")))
|
||||
(:text :wrap)
|
||||
|
||||
;Specials
|
||||
(:invisible del)
|
||||
((:but-not 6) (b "except"))
|
||||
((:begin-negative-lookahead 13) "[lookahead" :not-member-10 "{")
|
||||
((:end-negative-lookahead 2) "}]")
|
||||
((:line-break 12) "[line" nbsp "break]")
|
||||
((:no-line-break 15) "[no" nbsp "line" nbsp "break]")
|
||||
(:subscript sub)
|
||||
(:superscript sup)
|
||||
(:plain-subscript :subscript)
|
||||
((:action-begin 1) "[")
|
||||
((:action-end 1) "]")
|
||||
((:vector-begin 1) (b "["))
|
||||
((:vector-end 1) (b "]"))
|
||||
((:empty-vector 2) (b "[]"))
|
||||
((:vector-append 2) :circle-plus-10)
|
||||
((:tuple-begin 1) (b :left-triangle-bracket-10))
|
||||
((:tuple-end 1) (b :right-triangle-bracket-10))
|
||||
((:true 4) (:global-variable "true"))
|
||||
((:false 5) (:global-variable "false"))
|
||||
((:unique 6) (:semantic-keyword "unique"))
|
||||
))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; HTML STREAMS
|
||||
|
||||
(defstruct (html-stream (:include markup-stream)
|
||||
(:constructor allocate-html-stream (env head tail level logical-position enclosing-styles anchors))
|
||||
(:copier nil)
|
||||
(:predicate html-stream?))
|
||||
(enclosing-styles nil :type list :read-only t) ;A list of enclosing styles
|
||||
(anchors nil :type list :read-only t)) ;A mutable cons cell for accumulating anchors at the beginning of a paragraph
|
||||
; ;or nil if not inside a paragraph.
|
||||
|
||||
|
||||
(defmethod print-object ((html-stream html-stream) stream)
|
||||
(print-unreadable-object (html-stream stream :identity t)
|
||||
(write-string "html-stream" stream)))
|
||||
|
||||
|
||||
; Make a new, empty, open html-stream with the given definitions for its markup-env.
|
||||
(defun make-html-stream (markup-env level logical-position enclosing-styles anchors)
|
||||
(let ((head (list nil)))
|
||||
(allocate-html-stream markup-env head head level logical-position enclosing-styles anchors)))
|
||||
|
||||
|
||||
; Make a new, empty, open, top-level html-stream with the given definitions
|
||||
; for its markup-env. If links is true, allow links.
|
||||
(defun make-top-level-html-stream (html-definitions links)
|
||||
(let ((head (list nil))
|
||||
(markup-env (make-markup-env links)))
|
||||
(markup-env-define-alist markup-env html-definitions)
|
||||
(allocate-html-stream markup-env head head *markup-stream-top-level* nil nil nil)))
|
||||
|
||||
|
||||
; Return the approximate width of the html item; return t if it is a line break.
|
||||
; Also allow html tags as long as they do not contain line breaks.
|
||||
(defmethod markup-group-width ((html-stream html-stream) item)
|
||||
(if (consp item)
|
||||
(reduce #'+ (rest item) :key #'(lambda (subitem) (markup-group-width html-stream subitem)))
|
||||
(markup-width html-stream item)))
|
||||
|
||||
|
||||
; Create a top-level html-stream and call emitter to emit its contents.
|
||||
; emitter takes one argument -- an html-stream to which it should emit paragraphs.
|
||||
; Return the top-level html-stream. If links is true, allow links.
|
||||
(defun depict-html-top-level (title links emitter)
|
||||
(let ((html-stream (make-top-level-html-stream *html-definitions* links)))
|
||||
(markup-stream-append1 html-stream 'html)
|
||||
(depict-block-style (html-stream 'head)
|
||||
(depict-block-style (html-stream 'title)
|
||||
(markup-stream-append1 html-stream title))
|
||||
(markup-stream-append1 html-stream '((link (rel "stylesheet") (href "../styles.css"))))
|
||||
(markup-stream-append1 html-stream '((script (type "text/javascript") (language "JavaScript1.2") (src "../unicodeCompatibility.js")))))
|
||||
(depict-block-style (html-stream 'body)
|
||||
(funcall emitter html-stream))
|
||||
(let ((links (markup-env-links (html-stream-env html-stream))))
|
||||
(warn-missing-links links))
|
||||
html-stream))
|
||||
|
||||
|
||||
; Create a top-level html-stream and call emitter to emit its contents.
|
||||
; emitter takes one argument -- an html-stream to which it should emit paragraphs.
|
||||
; Write the resulting html to the text file with the given name (relative to the
|
||||
; local directory).
|
||||
; If links is true, allow links. If external-link-base is also provided, emit links for
|
||||
; predefined items and assume that they are located on the page specified by the
|
||||
; external-link-base string.
|
||||
(defun depict-html-to-local-file (filename title links emitter &key external-link-base)
|
||||
(let* ((*external-link-base* external-link-base)
|
||||
(top-html-stream (depict-html-top-level title links emitter)))
|
||||
(write-html-to-local-file filename (markup-stream-output top-html-stream)))
|
||||
filename)
|
||||
|
||||
|
||||
; Return the markup accumulated in the markup-stream after expanding all of its macros.
|
||||
; The markup-stream is closed after this function is called.
|
||||
(defmethod markup-stream-output ((html-stream html-stream))
|
||||
(coalesce-elements
|
||||
(unnest-html-source
|
||||
(markup-env-expand (markup-stream-env html-stream) (markup-stream-unexpanded-output html-stream) '(:none :nowrap :wrap :nest)))))
|
||||
|
||||
|
||||
|
||||
(defmethod depict-block-style-f ((html-stream html-stream) block-style flatten emitter)
|
||||
(assert-true (<= (markup-stream-level html-stream) *markup-stream-paragraph-level*))
|
||||
(assert-true (symbolp block-style))
|
||||
(if (or (null block-style)
|
||||
(and flatten (member block-style (html-stream-enclosing-styles html-stream))))
|
||||
(funcall emitter html-stream)
|
||||
(let ((inner-html-stream (make-html-stream (markup-stream-env html-stream)
|
||||
*markup-stream-paragraph-level*
|
||||
nil
|
||||
(cons block-style (html-stream-enclosing-styles html-stream))
|
||||
nil)))
|
||||
(markup-stream-append1 inner-html-stream block-style)
|
||||
(prog1
|
||||
(funcall emitter inner-html-stream)
|
||||
(let ((inner-output (markup-stream-unexpanded-output inner-html-stream)))
|
||||
(when (or (not flatten) (cdr inner-output))
|
||||
(markup-stream-append1 html-stream inner-output)))))))
|
||||
|
||||
|
||||
(defmethod depict-paragraph-f ((html-stream html-stream) paragraph-style emitter)
|
||||
(assert-true (= (markup-stream-level html-stream) *markup-stream-paragraph-level*))
|
||||
(assert-true (and paragraph-style (symbolp paragraph-style)))
|
||||
(let* ((anchors (list 'anchors))
|
||||
(inner-html-stream (make-html-stream (markup-stream-env html-stream)
|
||||
*markup-stream-content-level*
|
||||
(make-logical-position)
|
||||
(cons paragraph-style (html-stream-enclosing-styles html-stream))
|
||||
anchors)))
|
||||
(prog1
|
||||
(funcall emitter inner-html-stream)
|
||||
(markup-stream-append1 html-stream (cons paragraph-style
|
||||
(nreconc (cdr anchors)
|
||||
(markup-stream-unexpanded-output inner-html-stream)))))))
|
||||
|
||||
|
||||
(defmethod depict-char-style-f ((html-stream html-stream) char-style emitter)
|
||||
(assert-true (>= (markup-stream-level html-stream) *markup-stream-content-level*))
|
||||
(assert-true (and char-style (symbolp char-style)))
|
||||
(let ((inner-html-stream (make-html-stream (markup-stream-env html-stream)
|
||||
*markup-stream-content-level*
|
||||
(markup-stream-logical-position html-stream)
|
||||
(cons char-style (html-stream-enclosing-styles html-stream))
|
||||
(html-stream-anchors html-stream))))
|
||||
(markup-stream-append1 inner-html-stream char-style)
|
||||
(prog1
|
||||
(funcall emitter inner-html-stream)
|
||||
(markup-stream-append1 html-stream (markup-stream-unexpanded-output inner-html-stream)))))
|
||||
|
||||
|
||||
(defmethod ensure-no-enclosing-style ((html-stream html-stream) style)
|
||||
(when (member style (html-stream-enclosing-styles html-stream))
|
||||
(cerror "Ignore" "Style ~S should not be in effect" style)))
|
||||
|
||||
|
||||
(defmethod depict-anchor ((html-stream html-stream) link-prefix link-name duplicate)
|
||||
(assert-true (= (markup-stream-level html-stream) *markup-stream-content-level*))
|
||||
(let* ((links (markup-env-links (html-stream-env html-stream)))
|
||||
(name (record-link-definition links link-prefix link-name duplicate)))
|
||||
(when name
|
||||
(push (list (list 'a (list 'name name))) (cdr (html-stream-anchors html-stream))))))
|
||||
|
||||
|
||||
(defmethod depict-link-reference-f ((html-stream html-stream) link-prefix link-name external emitter)
|
||||
(assert-true (= (markup-stream-level html-stream) *markup-stream-content-level*))
|
||||
(let* ((links (markup-env-links (html-stream-env html-stream)))
|
||||
(href (record-link-reference links link-prefix link-name external)))
|
||||
(if href
|
||||
(let ((inner-html-stream (make-html-stream (markup-stream-env html-stream)
|
||||
*markup-stream-content-level*
|
||||
(markup-stream-logical-position html-stream)
|
||||
(html-stream-enclosing-styles html-stream)
|
||||
(html-stream-anchors html-stream))))
|
||||
(markup-stream-append1 inner-html-stream (list 'a (list 'href href)))
|
||||
(prog1
|
||||
(funcall emitter inner-html-stream)
|
||||
(markup-stream-append1 html-stream (markup-stream-unexpanded-output inner-html-stream))))
|
||||
(funcall emitter html-stream))))
|
||||
|
||||
|
||||
#|
|
||||
(write-html
|
||||
'(html
|
||||
(head
|
||||
(:nowrap (title "This is my title!<>")))
|
||||
((body (atr1 "abc") (beta) (qq))
|
||||
"My page this is " (br) (p))))
|
||||
|#
|
||||
|
|
@ -1,812 +0,0 @@
|
|||
;;; The contents of this file are subject to the Mozilla Public
|
||||
;;; License Version 1.1 (the "License"); you may not use this file
|
||||
;;; except in compliance with the License. You may obtain a copy of
|
||||
;;; the License at http://www.mozilla.org/MPL/
|
||||
;;;
|
||||
;;; Software distributed under the License is distributed on an "AS
|
||||
;;; IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
|
||||
;;; implied. See the License for the specific language governing
|
||||
;;; rights and limitations under the License.
|
||||
;;;
|
||||
;;; The Original Code is the Language Design and Prototyping Environment.
|
||||
;;;
|
||||
;;; The Initial Developer of the Original Code is Netscape Communications
|
||||
;;; Corporation. Portions created by Netscape Communications Corporation are
|
||||
;;; Copyright (C) 1999 Netscape Communications Corporation. All
|
||||
;;; Rights Reserved.
|
||||
;;;
|
||||
;;; Contributor(s): Waldemar Horwat <waldemar@acm.org>
|
||||
|
||||
;;;
|
||||
;;; RTF reader and writer
|
||||
;;;
|
||||
;;; Waldemar Horwat (waldemar@acm.org)
|
||||
;;;
|
||||
|
||||
|
||||
(defvar *rtf-author* "Waldemar Horwat")
|
||||
(defvar *rtf-company* "Netscape")
|
||||
|
||||
|
||||
;;; 1440 twips/inch
|
||||
;;; 20 twips/pt
|
||||
|
||||
(defparameter *rtf-definitions*
|
||||
'((:rtf-intro rtf 1 mac ansicpg 10000 uc 1 deff 0 deflang 2057 deflangfe 2057)
|
||||
|
||||
;Fonts
|
||||
((+ :rtf-intro) :fonttbl)
|
||||
(:fonttbl (fonttbl :fonts))
|
||||
|
||||
(:times f 0)
|
||||
((+ :fonts) (:times froman fcharset 256 fprq 2 (* panose "02020603050405020304") "Times New Roman;"))
|
||||
(:symbol f 3)
|
||||
((+ :fonts) (:symbol ftech fcharset 2 fprq 2 "Symbol;"))
|
||||
(:helvetica f 4)
|
||||
((+ :fonts) (:helvetica fnil fcharset 256 fprq 2 "Helvetica;"))
|
||||
(:courier f 5)
|
||||
((+ :fonts) (:courier fmodern fcharset 256 fprq 2 "Courier New;"))
|
||||
(:palatino f 6)
|
||||
((+ :fonts) (:palatino fnil fcharset 256 fprq 2 "Palatino;"))
|
||||
(:zapf-chancery f 7)
|
||||
((+ :fonts) (:zapf-chancery fscript fcharset 256 fprq 2 "Zapf Chancery;"))
|
||||
(:zapf-dingbats f 8)
|
||||
((+ :fonts) (:zapf-dingbats ftech fcharset 2 fprq 2 "Zapf Dingbats;"))
|
||||
|
||||
|
||||
;Color table
|
||||
((+ :rtf-intro) :colortbl)
|
||||
(:colortbl (colortbl ";" ;0
|
||||
red 0 green 0 blue 0 ";" ;1
|
||||
red 0 green 0 blue 255 ";" ;2
|
||||
red 0 green 255 blue 255 ";" ;3
|
||||
red 0 green 255 blue 0 ";" ;4
|
||||
red 255 green 0 blue 255 ";" ;5
|
||||
red 255 green 0 blue 0 ";" ;6
|
||||
red 255 green 255 blue 0 ";" ;7
|
||||
red 255 green 255 blue 255 ";" ;8
|
||||
red 0 green 0 blue 128 ";" ;9
|
||||
red 0 green 128 blue 128 ";" ;10
|
||||
red 0 green 128 blue 0 ";" ;11
|
||||
red 128 green 0 blue 128 ";" ;12
|
||||
red 128 green 0 blue 0 ";" ;13
|
||||
red 128 green 128 blue 0 ";" ;14
|
||||
red 128 green 128 blue 128 ";" ;15
|
||||
red 192 green 192 blue 192 ";")) ;16
|
||||
(:black cf 1)
|
||||
(:blue cf 2)
|
||||
(:turquoise cf 3)
|
||||
(:bright-green cf 4)
|
||||
(:pink cf 5)
|
||||
(:red cf 6)
|
||||
(:yellow cf 7)
|
||||
(:white cf 8)
|
||||
(:dark-blue cf 9)
|
||||
(:teal cf 10)
|
||||
(:green cf 11)
|
||||
(:violet cf 12)
|
||||
(:dark-red cf 13)
|
||||
(:dark-yellow cf 14)
|
||||
(:gray-50 cf 15)
|
||||
(:gray-25 cf 16)
|
||||
|
||||
|
||||
;Misc.
|
||||
(:spc " ")
|
||||
(:tab2 tab)
|
||||
(:tab3 tab)
|
||||
(:nbhy _) ;Non-breaking hyphen
|
||||
(:8-pt fs 16)
|
||||
(:9-pt fs 18)
|
||||
(:10-pt fs 20)
|
||||
(:12-pt fs 24)
|
||||
(:no-language lang 1024)
|
||||
(:english-us lang 1033)
|
||||
(:english-uk lang 2057)
|
||||
|
||||
(:english :english-us)
|
||||
|
||||
(:reset-section sectd)
|
||||
(:new-section sect)
|
||||
(:reset-paragraph pard plain)
|
||||
((:new-paragraph t) par)
|
||||
((:new-line t) line)
|
||||
|
||||
;Symbols (-10 suffix means 10-point, etc.)
|
||||
((:bullet 1) bullet)
|
||||
((:minus 1) endash)
|
||||
((:not-equal 1) u 8800 \' 173)
|
||||
((:less-or-equal 1) u 8804 \' 178)
|
||||
((:greater-or-equal 1) u 8805 \' 179)
|
||||
((:infinity 1) u 8734 \' 176)
|
||||
((:left-single-quote 1) lquote)
|
||||
((:right-single-quote 1) rquote)
|
||||
((:left-double-quote 1) ldblquote)
|
||||
((:right-double-quote 1) rdblquote)
|
||||
((:left-angle-quote 1) u 171 \' 199)
|
||||
((:right-angle-quote 1) u 187 \' 200)
|
||||
((:bottom-10 1) (field (* fldinst "SYMBOL 94 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:vector-assign-10 2) (field (* fldinst "SYMBOL 172 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:up-arrow-10 1) (field (* fldinst "SYMBOL 173 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:function-arrow-10 2) (field (* fldinst "SYMBOL 174 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:cartesian-product-10 2) (field (* fldinst "SYMBOL 180 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:identical-10 2) (field (* fldinst "SYMBOL 186 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:circle-plus-10 2) (field (* fldinst "SYMBOL 197 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:empty-10 2) (field (* fldinst "SYMBOL 198 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:intersection-10 1) (field (* fldinst "SYMBOL 199 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:union-10 1) (field (* fldinst "SYMBOL 200 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:member-10 2) (field (* fldinst "SYMBOL 206 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:not-member-10 2) (field (* fldinst "SYMBOL 207 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:derives-10 2) (field (* fldinst "SYMBOL 222 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:left-triangle-bracket-10 1) (field (* fldinst "SYMBOL 225 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:right-triangle-bracket-10 1) (field (* fldinst "SYMBOL 241 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:big-plus-10 2) (field (* fldinst "SYMBOL 58 \\f \"Zapf Dingbats\" \\s 10") (fldrslt :zapf-dingbats :10-pt)))
|
||||
|
||||
((:alpha 1) (field (* fldinst "SYMBOL 97 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:beta 1) (field (* fldinst "SYMBOL 98 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:chi 1) (field (* fldinst "SYMBOL 99 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:delta 1) (field (* fldinst "SYMBOL 100 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:epsilon 1) (field (* fldinst "SYMBOL 101 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:phi 1) (field (* fldinst "SYMBOL 102 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:gamma 1) (field (* fldinst "SYMBOL 103 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:eta 1) (field (* fldinst "SYMBOL 104 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:iota 1) (field (* fldinst "SYMBOL 105 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:kappa 1) (field (* fldinst "SYMBOL 107 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:lambda 1) (field (* fldinst "SYMBOL 108 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:mu 1) (field (* fldinst "SYMBOL 109 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:nu 1) (field (* fldinst "SYMBOL 110 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:omicron 1) (field (* fldinst "SYMBOL 111 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:pi 1) (field (* fldinst "SYMBOL 112 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:theta 1) (field (* fldinst "SYMBOL 113 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:rho 1) (field (* fldinst "SYMBOL 114 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:sigma 1) (field (* fldinst "SYMBOL 115 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:tau 1) (field (* fldinst "SYMBOL 116 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:upsilon 1) (field (* fldinst "SYMBOL 117 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:omega 1) (field (* fldinst "SYMBOL 119 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:xi 1) (field (* fldinst "SYMBOL 120 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:psi 1) (field (* fldinst "SYMBOL 121 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:zeta 1) (field (* fldinst "SYMBOL 122 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
|
||||
|
||||
;Styles
|
||||
((+ :rtf-intro) :stylesheet)
|
||||
(:stylesheet (stylesheet :styles))
|
||||
|
||||
(:normal-num 0)
|
||||
(:normal s :normal-num)
|
||||
((+ :styles) (widctlpar :10-pt :english snext :normal-num "Normal;"))
|
||||
|
||||
(:body-text-num 1)
|
||||
(:body-text s :body-text-num qj sa 120 widctlpar :10-pt :english)
|
||||
((+ :styles) (:body-text sbasedon :normal-num snext :body-text-num "Body Text;"))
|
||||
|
||||
(:header-num 2)
|
||||
(:header s :header-num nowidctlpar tqr tx 8640 :10-pt :english)
|
||||
((+ :styles) (:header sbasedon :normal-num snext :header-num "header;"))
|
||||
|
||||
(:footer-num 3)
|
||||
(:footer s :footer-num nowidctlpar tqc tx 4320 :10-pt :english)
|
||||
((+ :styles) (:footer sbasedon :normal-num snext :footer-num "footer;"))
|
||||
|
||||
(:section-heading-num 4)
|
||||
(:section-heading s :section-heading-num sa 60 keep keepn nowidctlpar hyphpar 0 level 3 b :12-pt :english)
|
||||
((+ :styles) (:section-heading sbasedon :subsection-heading-num snext :body-text-num "heading 3;"))
|
||||
|
||||
(:subsection-heading-num 5)
|
||||
(:subsection-heading s :subsection-heading-num sa 30 keep keepn nowidctlpar hyphpar 0 level 4 b :10-pt :english)
|
||||
((+ :styles) (:subsection-heading sbasedon :normal-num snext :body-text-num "heading 4;"))
|
||||
|
||||
(:grammar-num 10)
|
||||
(:grammar s :grammar-num nowidctlpar hyphpar 0 :10-pt :no-language)
|
||||
((+ :styles) (:grammar sbasedon :normal-num snext :grammar-num "Grammar;"))
|
||||
|
||||
(:grammar-header-num 11)
|
||||
(:grammar-header s :grammar-header-num sb 60 keep keepn nowidctlpar hyphpar 0 b :10-pt :english)
|
||||
((+ :styles) (:grammar-header sbasedon :normal-num snext :grammar-lhs-num "Grammar Header;"))
|
||||
|
||||
(:grammar-lhs-num 12)
|
||||
(:grammar-lhs s :grammar-lhs-num fi -1440 li 1800 sb 120 keep keepn nowidctlpar hyphpar 0 outlinelevel 4 :10-pt :no-language)
|
||||
((+ :styles) (:grammar-lhs sbasedon :grammar-num snext :grammar-rhs-num "Grammar LHS;"))
|
||||
|
||||
(:grammar-lhs-last-num 13)
|
||||
(:grammar-lhs-last s :grammar-lhs-last-num fi -1440 li 1800 sb 120 sa 120 keep nowidctlpar hyphpar 0 outlinelevel 4 :10-pt :no-language)
|
||||
((+ :styles) (:grammar-lhs-last sbasedon :grammar-num snext :grammar-lhs-num "Grammar LHS Last;"))
|
||||
|
||||
(:grammar-rhs-num 14)
|
||||
(:grammar-rhs s :grammar-rhs-num fi -1260 li 1800 keep keepn nowidctlpar tx 720 hyphpar 0 :10-pt :no-language)
|
||||
((+ :styles) (:grammar-rhs sbasedon :grammar-num snext :grammar-rhs-num "Grammar RHS;"))
|
||||
|
||||
(:grammar-rhs-last-num 15)
|
||||
(:grammar-rhs-last s :grammar-rhs-last-num fi -1260 li 1800 sa 120 keep nowidctlpar tx 720 hyphpar 0 :10-pt :no-language)
|
||||
((+ :styles) (:grammar-rhs-last sbasedon :grammar-rhs-num snext :grammar-lhs-num "Grammar RHS Last;"))
|
||||
|
||||
(:grammar-argument-num 16)
|
||||
(:grammar-argument s :grammar-argument-num fi -1440 li 1800 sb 120 sa 120 keep nowidctlpar hyphpar 0 outlinelevel 4 :10-pt :no-language)
|
||||
((+ :styles) (:grammar-argument sbasedon :grammar-num snext :grammar-lhs-num "Grammar Argument;"))
|
||||
|
||||
(:semantics-num 20)
|
||||
(:semantics s :semantics-num li 180 sb 60 sa 60 keep nowidctlpar hyphpar 0 :10-pt :no-language)
|
||||
((+ :styles) (:semantics sbasedon :normal-num snext :semantics-num "Semantics;"))
|
||||
|
||||
(:semantics-next-num 21)
|
||||
(:semantics-next s :semantics-next-num li 540 sa 60 keep nowidctlpar hyphpar 0 :10-pt :no-language)
|
||||
((+ :styles) (:semantics-next sbasedon :semantics-num snext :semantics-next-num "Semantics Next;"))
|
||||
|
||||
(:default-paragraph-font-num 30)
|
||||
(:default-paragraph-font cs :default-paragraph-font-num)
|
||||
((+ :styles) (* :default-paragraph-font additive "Default Paragraph Font;"))
|
||||
|
||||
(:page-number-num 31)
|
||||
(:page-number cs :page-number-num)
|
||||
((+ :styles) (* :page-number additive sbasedon :default-paragraph-font-num "page number;"))
|
||||
|
||||
(:character-literal-num 32)
|
||||
(:character-literal cs :character-literal-num b :courier :blue :no-language)
|
||||
((+ :styles) (* :character-literal additive sbasedon :default-paragraph-font-num "Character Literal;"))
|
||||
|
||||
(:character-literal-control-num 33)
|
||||
(:character-literal-control cs :character-literal-control-num b 0 :times :dark-blue)
|
||||
((+ :styles) (* :character-literal-control additive sbasedon :default-paragraph-font-num "Character Literal Control;"))
|
||||
|
||||
(:terminal-num 34)
|
||||
(:terminal cs :terminal-num b :palatino :teal :no-language)
|
||||
((+ :styles) (* :terminal additive sbasedon :default-paragraph-font-num "Terminal;"))
|
||||
|
||||
(:terminal-keyword-num 35)
|
||||
(:terminal-keyword cs :terminal-keyword-num b :courier :blue :no-language)
|
||||
((+ :styles) (* :terminal-keyword additive sbasedon :terminal-num "Terminal Keyword;"))
|
||||
|
||||
(:nonterminal-num 36)
|
||||
(:nonterminal cs :nonterminal-num i :palatino :dark-red :no-language)
|
||||
((+ :styles) (* :nonterminal additive sbasedon :default-paragraph-font-num "Nonterminal;"))
|
||||
|
||||
(:nonterminal-attribute-num 37)
|
||||
(:nonterminal-attribute cs :nonterminal-attribute-num i 0)
|
||||
((+ :styles) (* :nonterminal-attribute additive sbasedon :default-paragraph-font-num "Nonterminal Attribute;"))
|
||||
|
||||
(:nonterminal-argument-num 38)
|
||||
(:nonterminal-argument cs :nonterminal-argument-num)
|
||||
((+ :styles) (* :nonterminal-argument additive sbasedon :default-paragraph-font-num "Nonterminal Argument;"))
|
||||
|
||||
(:semantic-keyword-num 40)
|
||||
(:semantic-keyword cs :semantic-keyword-num b :times)
|
||||
((+ :styles) (* :semantic-keyword additive sbasedon :default-paragraph-font-num "Semantic Keyword;"))
|
||||
|
||||
(:type-expression-num 41)
|
||||
(:type-expression cs :type-expression-num :times :red :no-language)
|
||||
((+ :styles) (* :type-expression additive sbasedon :default-paragraph-font-num "Type Expression;"))
|
||||
|
||||
(:type-name-num 42)
|
||||
(:type-name cs :type-name-num scaps :times :red :no-language)
|
||||
((+ :styles) (* :type-name additive sbasedon :type-expression-num "Type Name;"))
|
||||
|
||||
(:field-name-num 43)
|
||||
(:field-name cs :field-name-num :helvetica :red :no-language)
|
||||
((+ :styles) (* :field-name additive sbasedon :type-expression-num "Field Name;"))
|
||||
|
||||
(:global-variable-num 44)
|
||||
(:global-variable cs :global-variable-num i :times :green :no-language)
|
||||
((+ :styles) (* :global-variable additive sbasedon :default-paragraph-font-num "Global Variable;"))
|
||||
|
||||
(:local-variable-num 45)
|
||||
(:local-variable cs :local-variable-num i :times :bright-green :no-language)
|
||||
((+ :styles) (* :local-variable additive sbasedon :default-paragraph-font-num "Local Variable;"))
|
||||
|
||||
(:action-name-num 46)
|
||||
(:action-name cs :action-name-num :zapf-chancery :violet :no-language)
|
||||
((+ :styles) (* :action-name additive sbasedon :default-paragraph-font-num "Action Name;"))
|
||||
|
||||
|
||||
;Headers and Footers
|
||||
(:header-group header :reset-paragraph :header)
|
||||
(:footer-group (footer :reset-paragraph :footer tab (field (* fldinst (:page-number " PAGE ")) (fldrslt (:page-number :no-language "1")))))
|
||||
|
||||
|
||||
;Document Formatting
|
||||
(:docfmt widowctrl
|
||||
ftnbj ;footnotes at bottom of page
|
||||
aenddoc ;endnotes at end of document
|
||||
fet 0 ;footnotes only -- no endnotes
|
||||
formshade ;shade form fields
|
||||
viewkind 4 ;normal view mode
|
||||
viewscale 125 ;125% view
|
||||
pgbrdrhead ;page border surrounds header
|
||||
pgbrdrfoot) ;page border surrounds footer
|
||||
|
||||
|
||||
;Section Formatting
|
||||
|
||||
|
||||
;Specials
|
||||
(:text :english)
|
||||
(:invisible v)
|
||||
((:but-not 6) (b "except"))
|
||||
((:begin-negative-lookahead 13) "[lookahead" :not-member-10 "{")
|
||||
((:end-negative-lookahead 2) "}]")
|
||||
((:line-break 12) "[line" ~ "break]")
|
||||
((:no-line-break 15) "[no" ~ "line" ~ "break]")
|
||||
(:subscript sub)
|
||||
(:superscript super)
|
||||
(:plain-subscript b 0 i 0 :subscript)
|
||||
((:action-begin 1) "[")
|
||||
((:action-end 1) "]")
|
||||
((:vector-begin 1) (b "["))
|
||||
((:vector-end 1) (b "]"))
|
||||
((:empty-vector 2) (b "[]"))
|
||||
((:vector-append 2) :circle-plus-10)
|
||||
((:tuple-begin 1) (b :left-triangle-bracket-10))
|
||||
((:tuple-end 1) (b :right-triangle-bracket-10))
|
||||
((:true 4) (:global-variable "true"))
|
||||
((:false 5) (:global-variable "false"))
|
||||
((:unique 6) (:semantic-keyword "unique"))
|
||||
))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; SIMPLE LINE BREAKER
|
||||
|
||||
(defparameter *limited-line-right-margin* 100)
|
||||
|
||||
; Housekeeping dynamic variables
|
||||
(defvar *current-limited-lines*) ;Items written so far via break-line to the innermost write-limited-lines
|
||||
(defvar *current-limited-lines-non-empty*) ;True if something was written to *current-limited-lines*
|
||||
(defvar *current-limited-position*) ;Number of characters written since the last newline to *current-limited-lines*
|
||||
|
||||
|
||||
; Capture the text written by the emitter function to its single parameter
|
||||
; (an output stream), dividing the text as specified by dynamically scoped calls
|
||||
; to break-line. Return the text as a base-string.
|
||||
(defun write-limited-lines (emitter)
|
||||
(let ((limited-stream (make-string-output-stream :element-type #-mcl 'character #+mcl 'base-character))
|
||||
(*current-limited-lines* (make-string-output-stream :element-type #-mcl 'character #+mcl 'base-character))
|
||||
(*current-limited-lines-non-empty* nil)
|
||||
(*current-limited-position* 0))
|
||||
(funcall emitter limited-stream)
|
||||
(break-line limited-stream)
|
||||
(get-output-stream-string *current-limited-lines*)))
|
||||
|
||||
|
||||
; Capture the text written by the emitter body to stream-var,
|
||||
; dividing the text as specified by dynamically scoped calls
|
||||
; to break-line. Write the result to the stream-var stream.
|
||||
(defmacro write-limited-block (stream-var &body emitter)
|
||||
`(progn
|
||||
(write-string
|
||||
(write-limited-lines #'(lambda (,stream-var) ,@emitter))
|
||||
,stream-var)
|
||||
nil))
|
||||
|
||||
|
||||
; Indicate that this is a potential place for a line break in the stream provided
|
||||
; by write-limited-lines. If subdivide is true, also indicate that line breaks can
|
||||
; be inserted anywhere between the previous such point indicated by break-line
|
||||
; (or the beginning of write-limited-lines if this is the first call to break-line)
|
||||
; and this point.
|
||||
(defun break-line (limited-stream &optional subdivide)
|
||||
(let* ((new-chars (get-output-stream-string limited-stream))
|
||||
(length (length new-chars)))
|
||||
(unless (zerop length)
|
||||
(labels
|
||||
((subdivide-new-chars (start)
|
||||
(let ((length-remaining (- length start))
|
||||
(room-on-line (- *limited-line-right-margin* *current-limited-position*)))
|
||||
(if (>= room-on-line length-remaining)
|
||||
(progn
|
||||
(write-string new-chars *current-limited-lines* :start start)
|
||||
(incf *current-limited-position* length-remaining))
|
||||
(let ((end (+ start room-on-line)))
|
||||
(write-string new-chars *current-limited-lines* :start start :end end)
|
||||
(write-char #\newline *current-limited-lines*)
|
||||
(setq *current-limited-position* 0)
|
||||
(subdivide-new-chars end))))))
|
||||
|
||||
(let ((position (+ *current-limited-position* length))
|
||||
(has-newlines (find #\newline new-chars)))
|
||||
(cond
|
||||
((or has-newlines
|
||||
(and (> position *limited-line-right-margin*) (not subdivide)))
|
||||
(when *current-limited-lines-non-empty*
|
||||
(write-char #\newline *current-limited-lines*))
|
||||
(write-string new-chars *current-limited-lines*)
|
||||
;Force a line break if break-line is called again and the current
|
||||
;new-chars contained a line break.
|
||||
(setq *current-limited-position*
|
||||
(if has-newlines
|
||||
(1+ *limited-line-right-margin*)
|
||||
length)))
|
||||
((<= position *limited-line-right-margin*)
|
||||
(write-string new-chars *current-limited-lines*)
|
||||
(setq *current-limited-position* position))
|
||||
((>= *current-limited-position* *limited-line-right-margin*)
|
||||
(write-char #\newline *current-limited-lines*)
|
||||
(setq *current-limited-position* 0)
|
||||
(subdivide-new-chars 0))
|
||||
(t (subdivide-new-chars 0)))
|
||||
(setq *current-limited-lines-non-empty* t))))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; RTF READER
|
||||
|
||||
|
||||
; Return true if char can be a part of an RTF control word.
|
||||
(defun rtf-control-word-char? (char)
|
||||
(and (char>= char #\a) (char<= char #\z)))
|
||||
|
||||
|
||||
; Read RTF from the character stream and return it in list form.
|
||||
; Each { ... } group is a sublist.
|
||||
; Each RTF control symbol or word is represented by a lisp symbol.
|
||||
; If an RTF control has a numeric argument, then its lisp symbol is followed
|
||||
; by an integer equal to the argument's value.
|
||||
; Newlines not escaped by backslashes are ignored.
|
||||
(defun read-rtf (stream)
|
||||
(labels
|
||||
((read (&optional (eof-error-p t))
|
||||
(read-char stream eof-error-p nil))
|
||||
|
||||
(read-group (nested)
|
||||
(let ((char (read nested)))
|
||||
(case char
|
||||
((nil) nil)
|
||||
(#\} (if nested
|
||||
nil
|
||||
(error "Mismatched }")))
|
||||
(#\{ (cons
|
||||
(read-group t)
|
||||
(read-group nested)))
|
||||
(#\\ (append
|
||||
(read-control)
|
||||
(read-group nested)))
|
||||
(#\newline (read-group nested))
|
||||
(t (read-text nested (list char))))))
|
||||
|
||||
(read-text (nested chars)
|
||||
(let ((char (read nested)))
|
||||
(case char
|
||||
((nil)
|
||||
(list (coerce (nreverse chars) 'string)))
|
||||
((#\{ #\} #\\)
|
||||
(cons (coerce (nreverse chars) 'string)
|
||||
(progn
|
||||
(unread-char char stream)
|
||||
(read-group nested))))
|
||||
(#\newline (read-text nested chars))
|
||||
(t (read-text nested (cons char chars))))))
|
||||
|
||||
(read-integer (value need-digit)
|
||||
(let* ((char (read))
|
||||
(digit (digit-char-p char)))
|
||||
(cond
|
||||
(digit (read-integer (+ (* value 10) digit) nil))
|
||||
(need-digit (error "Empty number"))
|
||||
((eql char #\space) value)
|
||||
(t (unread-char char stream)
|
||||
value))))
|
||||
|
||||
(read-hex (n-digits)
|
||||
(let ((value 0))
|
||||
(dotimes (n n-digits)
|
||||
(let ((digit (digit-char-p (read) 16)))
|
||||
(unless digit
|
||||
(error "Bad hex digit"))
|
||||
(setq value (+ (* value 16) digit))))
|
||||
value))
|
||||
|
||||
(read-control ()
|
||||
(let ((char (read)))
|
||||
(if (rtf-control-word-char? char)
|
||||
(let* ((control-string (read-control-word (list char)))
|
||||
(control-symbol (intern (string-upcase control-string)))
|
||||
(char (read)))
|
||||
(case char
|
||||
(#\space (list control-symbol))
|
||||
(#\- (list control-symbol (- (read-integer 0 t))))
|
||||
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
|
||||
(unread-char char stream)
|
||||
(list control-symbol (read-integer 0 t)))
|
||||
(t (unread-char char stream)
|
||||
(list control-symbol))))
|
||||
(let* ((control-string (string char))
|
||||
(control-symbol (intern (string-upcase control-string))))
|
||||
(if (eq control-symbol '\')
|
||||
(list control-symbol (read-hex 2))
|
||||
(list control-symbol))))))
|
||||
|
||||
(read-control-word (chars)
|
||||
(let ((char (read)))
|
||||
(if (rtf-control-word-char? char)
|
||||
(read-control-word (cons char chars))
|
||||
(progn
|
||||
(unread-char char stream)
|
||||
(coerce (nreverse chars) 'string))))))
|
||||
|
||||
(read-group nil)))
|
||||
|
||||
|
||||
; Read RTF from the text file with the given name (relative to the
|
||||
; local directory) and return it in list form.
|
||||
(defun read-rtf-from-local-file (filename)
|
||||
(with-open-file (stream (filename-to-semantic-engine-pathname filename)
|
||||
:direction :input)
|
||||
(read-rtf stream)))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; RTF WRITER
|
||||
|
||||
|
||||
(defconstant *rtf-special* '(#\\ #\{ #\}))
|
||||
|
||||
|
||||
; Return the string with characters in *rtf-special* preceded by backslashes.
|
||||
; If there are no such characters, the returned string may be eq to the input string.
|
||||
(defun escape-rtf (string)
|
||||
(let ((i (position-if #'(lambda (char) (member char *rtf-special*)) string)))
|
||||
(if i
|
||||
(let* ((string-length (length string))
|
||||
(result-string (make-array string-length :element-type #-mcl 'character #+mcl 'base-character :adjustable t :fill-pointer i)))
|
||||
(replace result-string string)
|
||||
(do ((i i (1+ i)))
|
||||
((= i string-length))
|
||||
(let ((char (char string i)))
|
||||
(when (member char *rtf-special*)
|
||||
(vector-push-extend #\\ result-string))
|
||||
(vector-push-extend char result-string)))
|
||||
result-string)
|
||||
string)))
|
||||
|
||||
|
||||
; Write the string with characters in *rtf-special* preceded by backslashes and not allowing
|
||||
; linebreaks between a backslash and the character it is escaping. Start with the character
|
||||
; at offset start in the given string.
|
||||
(defun write-escaped-rtf (stream string start)
|
||||
(let ((end (position-if #'(lambda (char) (member char *rtf-special*)) string :start start)))
|
||||
(if end
|
||||
(progn
|
||||
(unless (= start end)
|
||||
(write-string string stream :start start :end end)
|
||||
(break-line stream t))
|
||||
(write-char #\\ stream)
|
||||
(write-char (char string end) stream)
|
||||
(break-line stream)
|
||||
(write-escaped-rtf stream string (1+ end)))
|
||||
(unless (= start (length string))
|
||||
(write-string string stream :start start)
|
||||
(break-line stream t)))))
|
||||
|
||||
|
||||
; Write RTF to the character stream. See read-rtf for a description
|
||||
; of the layout of the rtf list.
|
||||
(defun write-rtf (rtf &optional (stream t))
|
||||
(labels
|
||||
((write-group-contents (rtf stream)
|
||||
(let ((first-rtf (first rtf))
|
||||
(rest-rtf (rest rtf)))
|
||||
(cond
|
||||
((listp first-rtf)
|
||||
(write-group first-rtf stream t))
|
||||
((stringp first-rtf)
|
||||
(write-escaped-rtf stream first-rtf 0))
|
||||
((symbolp first-rtf)
|
||||
(write-char #\\ stream)
|
||||
(write first-rtf :stream stream)
|
||||
(cond
|
||||
((alpha-char-p (char (symbol-name first-rtf) 0))
|
||||
(when (integerp (first rest-rtf))
|
||||
(write (first rest-rtf) :stream stream)
|
||||
(setq rest-rtf (rest rest-rtf)))
|
||||
(let ((first-rest (first rest-rtf)))
|
||||
(when (and (stringp first-rest)
|
||||
(or (zerop (length first-rest))
|
||||
(let ((ch (char first-rest 0)))
|
||||
(or (alphanumericp ch)
|
||||
(eql ch #\space)
|
||||
(eql ch #\-)
|
||||
(eql ch #\+)))))
|
||||
(write-char #\space stream))))
|
||||
((eq first-rtf '\')
|
||||
(unless (integerp (first rest-rtf))
|
||||
(error "Bad rtf: ~S" rtf))
|
||||
(format stream "~2,'0x" (first rest-rtf))
|
||||
(setq rest-rtf (rest rest-rtf)))))
|
||||
(t (error "Bad rtf: ~S" rtf)))
|
||||
(when rest-rtf
|
||||
(break-line stream)
|
||||
(write-group-contents rest-rtf stream))))
|
||||
|
||||
(write-group (rtf stream nested)
|
||||
(write-limited-block stream
|
||||
(when nested
|
||||
(write-char #\{ stream))
|
||||
(when rtf
|
||||
(write-group-contents rtf stream))
|
||||
(when nested
|
||||
(write-char #\} stream)))))
|
||||
|
||||
(with-standard-io-syntax
|
||||
(let ((*print-readably* nil)
|
||||
(*print-escape* nil)
|
||||
(*print-case* :downcase))
|
||||
(write-group rtf stream nil)))))
|
||||
|
||||
|
||||
; Write RTF to the text file with the given name (relative to the
|
||||
; local directory).
|
||||
(defun write-rtf-to-local-file (filename rtf)
|
||||
(with-open-file (stream (filename-to-semantic-engine-pathname filename)
|
||||
:direction :output
|
||||
:if-exists :supersede
|
||||
#+mcl :external-format #+mcl "RTF "
|
||||
#+mcl :mac-file-creator #+mcl "MSWD")
|
||||
(write-rtf rtf stream)))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; RTF STREAMS
|
||||
|
||||
(defstruct (rtf-stream (:include markup-stream)
|
||||
(:constructor allocate-rtf-stream (env head tail level logical-position))
|
||||
(:copier nil)
|
||||
(:predicate rtf-stream?))
|
||||
(style nil :type symbol)) ;Current section or paragraph style or nil if none or emitting paragraph contents
|
||||
|
||||
|
||||
(defmethod print-object ((rtf-stream rtf-stream) stream)
|
||||
(print-unreadable-object (rtf-stream stream :identity t)
|
||||
(write-string "rtf-stream" stream)))
|
||||
|
||||
|
||||
; Make a new, empty, open rtf-stream with the given definitions for its markup-env.
|
||||
(defun make-rtf-stream (markup-env level &optional logical-position)
|
||||
(let ((head (list nil)))
|
||||
(allocate-rtf-stream markup-env head head level logical-position)))
|
||||
|
||||
|
||||
; Make a new, empty, open, top-level rtf-stream with the given definitions
|
||||
; for its markup-env.
|
||||
(defun make-top-level-rtf-stream (rtf-definitions)
|
||||
(let ((head (list nil))
|
||||
(markup-env (make-markup-env nil)))
|
||||
(markup-env-define-alist markup-env rtf-definitions)
|
||||
(allocate-rtf-stream markup-env head head *markup-stream-top-level* nil)))
|
||||
|
||||
|
||||
; Append a block to the end of the rtf-stream. The block may be inlined
|
||||
; if nothing else follows it in the rtf-stream.
|
||||
(defun rtf-stream-append-or-inline-block (rtf-stream block)
|
||||
(assert-type block list)
|
||||
(when block
|
||||
(let ((pretail (markup-stream-tail rtf-stream)))
|
||||
(markup-stream-append1 rtf-stream block)
|
||||
(setf (markup-stream-pretail rtf-stream) pretail))))
|
||||
|
||||
|
||||
; Return the approximate width of the rtf item; return t if it is a line break.
|
||||
; Also allow rtf groups as long as they do not contain line breaks.
|
||||
(defmethod markup-group-width ((rtf-stream rtf-stream) item)
|
||||
(if (consp item)
|
||||
(reduce #'+ item :key #'(lambda (subitem) (markup-group-width rtf-stream subitem)))
|
||||
(markup-width rtf-stream item)))
|
||||
|
||||
|
||||
; Return the information group or nil if none is needed.
|
||||
; Any of the inputs can be nil, in which case the corresponding info entry is omitted.
|
||||
(defun generate-document-info (title author company time)
|
||||
(and (or title author company time)
|
||||
(cons 'info
|
||||
(nconc
|
||||
(and title (list (list 'title (assert-type title string))))
|
||||
(and author (list (list 'author (assert-type author string))
|
||||
(list 'operator author)))
|
||||
(and time (multiple-value-bind (second minute hour day month year) (decode-universal-time time)
|
||||
(let ((rtf-time (list 'yr year 'mo month 'dy day 'hr hour 'min minute 'sec second)))
|
||||
(list (cons 'creatim rtf-time)
|
||||
(cons 'revtim rtf-time)
|
||||
(list 'edmins 0)))))
|
||||
(and company (list (list '* 'company (assert-type company string))))))))
|
||||
|
||||
|
||||
(defun time-to-string (time)
|
||||
(multiple-value-bind (second minute hour day month year weekday) (decode-universal-time time)
|
||||
(declare (ignore second minute hour))
|
||||
(format nil "~A, ~A ~D, ~D"
|
||||
(nth weekday '("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday"))
|
||||
(nth (1- month) '("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December"))
|
||||
day
|
||||
year)))
|
||||
|
||||
|
||||
; Return the header group.
|
||||
(defun generate-header-group (title time)
|
||||
(list :header-group (assert-type title string) 'tab (time-to-string time)))
|
||||
|
||||
|
||||
; Create a top-level rtf-stream and call emitter to emit its contents.
|
||||
; emitter takes one argument -- an rtf-stream to which it should emit paragraphs.
|
||||
; Return the top-level rtf-stream.
|
||||
(defun depict-rtf-top-level (title emitter)
|
||||
(let* ((top-rtf-stream (make-top-level-rtf-stream *rtf-definitions*))
|
||||
(rtf-stream (make-rtf-stream (markup-stream-env top-rtf-stream) *markup-stream-paragraph-level*))
|
||||
(time (get-universal-time)))
|
||||
(markup-stream-append1 rtf-stream ':rtf-intro)
|
||||
(let ((info (generate-document-info title *rtf-author* *rtf-company* time)))
|
||||
(when info
|
||||
(markup-stream-append1 rtf-stream info)))
|
||||
(markup-stream-append1 rtf-stream ':docfmt)
|
||||
(markup-stream-append1 rtf-stream ':reset-section)
|
||||
(markup-stream-append1 rtf-stream (generate-header-group title time))
|
||||
(markup-stream-append1 rtf-stream ':footer-group)
|
||||
(funcall emitter rtf-stream)
|
||||
(markup-stream-append1 top-rtf-stream (markup-stream-unexpanded-output rtf-stream))
|
||||
top-rtf-stream))
|
||||
|
||||
|
||||
; Create a top-level rtf-stream and call emitter to emit its contents.
|
||||
; emitter takes one argument -- an rtf-stream to which it should emit paragraphs.
|
||||
; Write the resulting RTF to the text file with the given name (relative to the
|
||||
; local directory).
|
||||
(defun depict-rtf-to-local-file (filename title emitter)
|
||||
(let ((top-rtf-stream (depict-rtf-top-level title emitter)))
|
||||
(write-rtf-to-local-file filename (markup-stream-output top-rtf-stream)))
|
||||
filename)
|
||||
|
||||
|
||||
; Return the markup accumulated in the markup-stream after expanding all of its macros.
|
||||
; The markup-stream is closed after this function is called.
|
||||
(defmethod markup-stream-output ((rtf-stream rtf-stream))
|
||||
(markup-env-expand (markup-stream-env rtf-stream) (markup-stream-unexpanded-output rtf-stream) nil))
|
||||
|
||||
|
||||
(defmethod depict-block-style-f ((rtf-stream rtf-stream) block-style flatten emitter)
|
||||
(declare (ignore block-style flatten))
|
||||
(assert-true (= (markup-stream-level rtf-stream) *markup-stream-paragraph-level*))
|
||||
(funcall emitter rtf-stream))
|
||||
|
||||
|
||||
(defmethod depict-paragraph-f ((rtf-stream rtf-stream) paragraph-style emitter)
|
||||
(assert-true (= (markup-stream-level rtf-stream) *markup-stream-paragraph-level*))
|
||||
(assert-true (and paragraph-style (symbolp paragraph-style)))
|
||||
(unless (eq paragraph-style (rtf-stream-style rtf-stream))
|
||||
(markup-stream-append1 rtf-stream ':reset-paragraph)
|
||||
(markup-stream-append1 rtf-stream paragraph-style))
|
||||
(setf (rtf-stream-style rtf-stream) nil)
|
||||
(setf (markup-stream-level rtf-stream) *markup-stream-content-level*)
|
||||
(setf (markup-stream-logical-position rtf-stream) (make-logical-position))
|
||||
(prog1
|
||||
(funcall emitter rtf-stream)
|
||||
(setf (markup-stream-level rtf-stream) *markup-stream-paragraph-level*)
|
||||
(setf (rtf-stream-style rtf-stream) paragraph-style)
|
||||
(setf (markup-stream-logical-position rtf-stream) nil)
|
||||
(markup-stream-append1 rtf-stream ':new-paragraph)))
|
||||
|
||||
|
||||
(defmethod depict-char-style-f ((rtf-stream rtf-stream) char-style emitter)
|
||||
(assert-true (>= (markup-stream-level rtf-stream) *markup-stream-content-level*))
|
||||
(assert-true (and char-style (symbolp char-style)))
|
||||
(let ((inner-rtf-stream (make-rtf-stream (markup-stream-env rtf-stream) *markup-stream-content-level* (markup-stream-logical-position rtf-stream))))
|
||||
(markup-stream-append1 inner-rtf-stream char-style)
|
||||
(prog1
|
||||
(funcall emitter inner-rtf-stream)
|
||||
(rtf-stream-append-or-inline-block rtf-stream (markup-stream-unexpanded-output inner-rtf-stream)))))
|
||||
|
||||
|
||||
(defmethod ensure-no-enclosing-style ((rtf-stream rtf-stream) style)
|
||||
(declare (ignore style)))
|
||||
|
||||
|
||||
(defmethod depict-anchor ((rtf-stream rtf-stream) link-prefix link-name duplicate)
|
||||
(declare (ignore link-prefix link-name duplicate))
|
||||
(assert-true (= (markup-stream-level rtf-stream) *markup-stream-content-level*)))
|
||||
|
||||
|
||||
(defmethod depict-link-reference-f ((rtf-stream rtf-stream) link-prefix link-name external emitter)
|
||||
(declare (ignore link-prefix link-name external))
|
||||
(assert-true (= (markup-stream-level rtf-stream) *markup-stream-content-level*))
|
||||
(funcall emitter rtf-stream))
|
||||
|
||||
|
||||
#|
|
||||
(setq r (read-rtf-from-local-file "SampleStyles.rtf"))
|
||||
(write-rtf-to-local-file "Y.rtf" r)
|
||||
|#
|
||||
|
|
@ -464,6 +464,7 @@
|
|||
(:grammar-argument (:nest :nowrap (div (class "grammar-argument"))))
|
||||
(:semantics (:nest :nowrap (p (class "semantics"))))
|
||||
(:semantics-next (:nest :nowrap (p (class "semantics-next"))))
|
||||
(:semantic-comment (:nest :nowrap (p (class "semantic-comment"))))
|
||||
|
||||
;Inline Styles
|
||||
(:script (script (type "text/javascript")))
|
||||
|
|
@ -499,6 +500,7 @@
|
|||
((:vector-begin 1) (b "["))
|
||||
((:vector-end 1) (b "]"))
|
||||
((:empty-vector 2) (b "[]"))
|
||||
((:vector-construct 1) (b "|"))
|
||||
((:vector-append 2) :circle-plus-10)
|
||||
((:tuple-begin 1) (b :left-triangle-bracket-10))
|
||||
((:tuple-end 1) (b :right-triangle-bracket-10))
|
||||
|
|
|
|||
|
|
@ -232,6 +232,10 @@
|
|||
(:semantics-next s :semantics-next-num li 540 sa 60 keep nowidctlpar hyphpar 0 :10-pt :no-language)
|
||||
((+ :styles) (:semantics-next sbasedon :semantics-num snext :semantics-next-num "Semantics Next;"))
|
||||
|
||||
(:semantic-comment-num 22)
|
||||
(:semantic-comment s :semantic-comment-num qj li 180 sb 120 sa 0 widctlpar :10-pt :english)
|
||||
((+ :styles) (:semantic-comment sbasedon :normal-num snext :semantics-num "Semantic Comment;"))
|
||||
|
||||
(:default-paragraph-font-num 30)
|
||||
(:default-paragraph-font cs :default-paragraph-font-num)
|
||||
((+ :styles) (* :default-paragraph-font additive "Default Paragraph Font;"))
|
||||
|
|
@ -333,6 +337,7 @@
|
|||
((:vector-begin 1) (b "["))
|
||||
((:vector-end 1) (b "]"))
|
||||
((:empty-vector 2) (b "[]"))
|
||||
((:vector-construct 1) (b "|"))
|
||||
((:vector-append 2) :circle-plus-10)
|
||||
((:tuple-begin 1) (b :left-triangle-bracket-10))
|
||||
((:tuple-end 1) (b :right-triangle-bracket-10))
|
||||
|
|
|
|||
Загрузка…
Ссылка в новой задаче