mozilla
/
mozilla-history
зеркало из https://github.com/mozilla/mozilla-history.git
1
0
Форкнуть 0
Код Задачи Пакеты Проекты Релизы Вики Активность

Transitioned to paragraph/DIV-based styles

This commit is contained in:
waldemar%netscape.com 2001-09-20 00:13:32 +00:00
Родитель bd8682892c
Коммит 51d86fad6d
9 изменённых файлов: 948 добавлений и 761 удалений
Показать статистику Скачать Patch файл Скачать Diff файл Показать все файлы Свернуть все файлы

599
js2/semantics/CalculusMarkup.lisp
Просмотреть файл

@ -47,7 +47,7 @@
some every satisfies
such that
tag tuple record
function
proc
begin end nothing
if then elsif else
while do
@ -403,7 +403,6 @@
annotated-parameters
:indent 4
:prefix "("
:prefix-break 0
:suffix ")"
:separator ","
:break 1
@ -428,7 +427,8 @@
(when spaces
(depict-space markup-stream))
(depict-item-or-group-list markup-stream (primitive-markup1 primitive))
(depict-break markup-stream (if spaces 1 0)))
(when spaces
(depict-break markup-stream 1)))
(depict-expression markup-stream world (second annotated-arg-exprs) (primitive-level2 primitive))))
(:unary
(assert-true (= (length annotated-arg-exprs) 1))
@ -548,54 +548,18 @@
(depict-expression markup-stream world annotated-expr level)))
(defun depict-function-signature (markup-stream world arg-binding-exprs result-type-expr show-type)
(depict-logical-block (markup-stream 12)
(depict-break markup-stream 0)
(depict-list markup-stream
#'(lambda (markup-stream arg-binding)
(depict-local-variable markup-stream (first arg-binding))
(depict markup-stream ": ")
(depict-type-expr markup-stream world (second arg-binding)))
arg-binding-exprs
:indent 2
:prefix "("
:suffix ")"
:separator ","
:break 1
:empty nil)
(unless (or (eq result-type-expr 'void) (not show-type))
(depict markup-stream ":")
(depict-break markup-stream 1)
(depict-type-expr markup-stream world result-type-expr))))
(defun depict-function-body (markup-stream world body-annotated-stmts)
(depict-logical-block (markup-stream 4)
(let ((first-annotated-stmt (first body-annotated-stmts)))
(if (and body-annotated-stmts
(endp (cdr body-annotated-stmts))
(special-form-annotated-stmt? world 'return first-annotated-stmt)
(cdr first-annotated-stmt))
(progn
(depict-break markup-stream 1)
(depict markup-stream :identical-10 " ")
(depict-expression markup-stream world (second first-annotated-stmt) %expr%))
(progn
(depict-break markup-stream t)
(depict-semantic-keyword markup-stream 'begin nil)
(depict-logical-block (markup-stream 4)
(depict-statements markup-stream world t body-annotated-stmts))
(depict-break markup-stream t)
(depict-semantic-keyword markup-stream 'end nil))))))
; (lambda ((<var1> <type1> [:unused]) ... (<varn> <typen> [:unused])) <result-type> . <statements>)
(defun depict-lambda (markup-stream world level arg-binding-exprs result-type-expr &rest body-annotated-stmts)
(declare (ignore markup-stream world level arg-binding-exprs result-type-expr body-annotated-stmts))
(error "Depiction of raw lambdas not supported"))
#|
(defun depict-lambda (markup-stream world level arg-binding-exprs result-type-expr &rest body-annotated-stmts)
(depict-expr-parentheses (markup-stream level %expr%)
(depict-logical-block (markup-stream 0)
(depict-semantic-keyword markup-stream 'function nil)
(depict-semantic-keyword markup-stream 'proc nil)
(depict-function-signature markup-stream world arg-binding-exprs result-type-expr t)
(depict-function-body markup-stream world body-annotated-stmts))))
(depict-function-body markup-stream world nil :statement body-annotated-stmts))))
|#
; (if <condition-expr> <true-expr> <false-expr>)
@ -883,7 +847,6 @@
annotated-exprs
:indent 4
:prefix (if mutable :record-begin :tuple-begin)
:prefix-break 0
:suffix (if mutable :record-end :tuple-end)
:separator ","
:break 1
@ -934,150 +897,185 @@
;;; DEPICTING STATEMENTS
; Emit markup for the annotated statement.
(defun depict-statement (markup-stream world annotated-stmt)
(apply (get (first annotated-stmt) :depict-statement) markup-stream world (rest annotated-stmt)))
(defmacro depict-statement-block (markup-stream &body body)
`(depict-division-block (,markup-stream :statement '(:statement) '(:level))
,@body))
; Emit markup for the block of annotated statements, including the preceding line breaks using
; the given prefix.
(defun depict-statements (markup-stream world prefix-break annotated-stmts)
(if annotated-stmts
(depict-list markup-stream
#'(lambda (markup-stream annotated-stmt)
(depict-statement markup-stream world annotated-stmt))
annotated-stmts
:indent 0
:prefix-break prefix-break
:separator ";"
:break t)
(progn
(depict-break markup-stream prefix-break)
(depict-semantic-keyword markup-stream 'nothing nil))))
(defmacro depict-statement-block-last (markup-stream &body body)
`(depict-division-block (,markup-stream :statement-last '(:statement :statement-last) '(:level))
,@body))
; Emit markup for the annotated statement. The markup stream should be collecting divisions.
; If semicolon is true, depict a semicolon after the statement.
(defun depict-statement (markup-stream world semicolon annotated-stmt)
(apply (get (first annotated-stmt) :depict-statement) markup-stream world semicolon (rest annotated-stmt)))
; If semicolon is true, depict a semicolon.
(defun depict-semicolon (markup-stream semicolon)
(when semicolon
(depict markup-stream ";")))
; Emit markup for the block of annotated statements indented by one level. The markup stream
; should be collecting divisions.
; If semicolon is true, depict a semicolon after the statements.
(defun depict-statements (markup-stream world semicolon annotated-stmts)
(depict-division-style (markup-stream :level)
(if annotated-stmts
(mapl #'(lambda (annotated-stmts)
(depict-statement markup-stream world (or (rest annotated-stmts) semicolon) (first annotated-stmts)))
annotated-stmts)
(depict-paragraph (markup-stream :statement)
(depict-semantic-keyword markup-stream 'nothing nil)
(depict-semicolon markup-stream semicolon)))))
; (exec <expr>)
(defun depict-exec (markup-stream world annotated-expr)
(depict-expression markup-stream world annotated-expr %expr%))
(defun depict-exec (markup-stream world semicolon annotated-expr)
(depict-paragraph (markup-stream :statement)
(depict-expression markup-stream world annotated-expr %expr%)
(depict-semicolon markup-stream semicolon)))
; (const <name> <type> <value>)
; (var <name> <type> <value>)
(defun depict-var (markup-stream world name type-expr value-annotated-expr)
(depict-local-variable markup-stream name)
(depict markup-stream ": ")
(depict-type-expr markup-stream world type-expr)
(depict markup-stream " " :assign-10)
(depict-logical-block (markup-stream 6)
(depict-break markup-stream 1)
(depict-expression markup-stream world value-annotated-expr %expr%)))
(defun depict-var (markup-stream world semicolon name type-expr value-annotated-expr)
(depict-paragraph (markup-stream :statement)
(depict-local-variable markup-stream name)
(depict markup-stream ": ")
(depict-type-expr markup-stream world type-expr)
(depict markup-stream " " :assign-10)
(depict-logical-block (markup-stream 6)
(depict-break markup-stream 1)
(depict-expression markup-stream world value-annotated-expr %expr%)
(depict-semicolon markup-stream semicolon))))
; (function (<name> (<var1> <type1> [:unused]) ... (<varn> <typen> [:unused])) <result-type> . <statements>)
(defun depict-function (markup-stream world name-and-arg-binding-exprs result-type-expr &rest body-annotated-stmts)
(depict-logical-block (markup-stream 0)
(depict-semantic-keyword markup-stream 'function :after)
(depict-local-variable markup-stream (first name-and-arg-binding-exprs))
(depict-function-signature markup-stream world (rest name-and-arg-binding-exprs) result-type-expr t)
(depict-function-body markup-stream world body-annotated-stmts)))
(defun depict-function (markup-stream world semicolon name-and-arg-binding-exprs result-type-expr &rest body-annotated-stmts)
(depict-statement-block markup-stream
(depict-paragraph (markup-stream :statement)
(depict-semantic-keyword markup-stream 'proc :after)
(depict-local-variable markup-stream (first name-and-arg-binding-exprs))
(depict-function-signature markup-stream world (rest name-and-arg-binding-exprs) result-type-expr t))
(depict-function-body markup-stream world semicolon :statement body-annotated-stmts)))
; (<- <name> <value>)
(defun depict-<- (markup-stream world name value-annotated-expr)
(depict-local-variable markup-stream name)
(depict markup-stream " " :assign-10)
(depict-logical-block (markup-stream 6)
(depict-break markup-stream 1)
(depict-expression markup-stream world value-annotated-expr %expr%)))
(defun depict-<- (markup-stream world semicolon name value-annotated-expr)
(depict-paragraph (markup-stream :statement)
(depict-local-variable markup-stream name)
(depict markup-stream " " :assign-10)
(depict-logical-block (markup-stream 6)
(depict-break markup-stream 1)
(depict-expression markup-stream world value-annotated-expr %expr%)
(depict-semicolon markup-stream semicolon))))
; (&= <record-expr> <value-expr>)
(defun depict-&= (markup-stream world record-type label record-annotated-expr value-annotated-expr)
(depict-& markup-stream world %unary% record-type label record-annotated-expr)
(depict markup-stream " " :assign-10)
(depict-logical-block (markup-stream 6)
(depict-break markup-stream 1)
(depict-expression markup-stream world value-annotated-expr %expr%)))
(defun depict-&= (markup-stream world semicolon record-type label record-annotated-expr value-annotated-expr)
(depict-paragraph (markup-stream :statement)
(depict-& markup-stream world %unary% record-type label record-annotated-expr)
(depict markup-stream " " :assign-10)
(depict-logical-block (markup-stream 6)
(depict-break markup-stream 1)
(depict-expression markup-stream world value-annotated-expr %expr%)
(depict-semicolon markup-stream semicolon))))
; (return [<value-expr>])
(defun depict-return (markup-stream world value-annotated-expr)
(depict-logical-block (markup-stream 4)
(depict-semantic-keyword markup-stream 'return nil)
(when value-annotated-expr
(depict-space markup-stream)
(depict-expression markup-stream world value-annotated-expr %expr%))))
(defun depict-return (markup-stream world semicolon value-annotated-expr)
(depict-paragraph (markup-stream :statement)
(depict-logical-block (markup-stream 4)
(depict-semantic-keyword markup-stream 'return nil)
(when value-annotated-expr
(depict-space markup-stream)
(depict-expression markup-stream world value-annotated-expr %expr%))
(depict-semicolon markup-stream semicolon))))
; (cond (<condition-expr> . <statements>) ... (<condition-expr> . <statements>) [(nil . <statements>)])
(defun depict-cond (markup-stream world &rest annotated-cases)
(defun depict-cond (markup-stream world semicolon &rest annotated-cases)
(assert-true (and annotated-cases (caar annotated-cases)))
(depict-logical-block (markup-stream 0)
(depict-statement-block markup-stream
(do ((annotated-cases annotated-cases (rest annotated-cases))
(else nil t))
((endp annotated-cases))
(let ((annotated-case (first annotated-cases)))
(depict-logical-block (markup-stream 4)
(let ((condition-annotated-expr (first annotated-case)))
(if condition-annotated-expr
(progn
(depict-semantic-keyword markup-stream (if else 'elsif 'if) :after)
(depict-logical-block (markup-stream 4)
(depict-expression markup-stream world condition-annotated-expr %expr%))
(depict-semantic-keyword markup-stream 'then :before))
(depict-semantic-keyword markup-stream 'else nil)))
(depict-statements markup-stream world 1 (rest annotated-case)))
(depict-break markup-stream 1)))
(depict-semantic-keyword markup-stream 'end :after)
(depict-semantic-keyword markup-stream 'if nil)))
(depict-statement-block markup-stream
(depict-paragraph (markup-stream :statement)
(let ((condition-annotated-expr (first annotated-case)))
(if condition-annotated-expr
(progn
(depict-semantic-keyword markup-stream (if else 'elsif 'if) :after)
(depict-logical-block (markup-stream 4)
(depict-expression markup-stream world condition-annotated-expr %expr%))
(depict-semantic-keyword markup-stream 'then :before))
(depict-semantic-keyword markup-stream 'else nil))))
(depict-statements markup-stream world nil (rest annotated-case)))))
(depict-paragraph (markup-stream :statement)
(depict-semantic-keyword markup-stream 'end :after)
(depict-semantic-keyword markup-stream 'if nil)
(depict-semicolon markup-stream semicolon))))
; (while <condition-expr> . <statements>)
(defun depict-while (markup-stream world condition-annotated-expr &rest loop-annotated-stmts)
(depict-logical-block (markup-stream 0)
(depict-logical-block (markup-stream 4)
(depict-semantic-keyword markup-stream 'while :after)
(depict-logical-block (markup-stream 4)
(depict-expression markup-stream world condition-annotated-expr %expr%))
(depict-semantic-keyword markup-stream 'do :before)
(depict-statements markup-stream world 1 loop-annotated-stmts))
(depict-break markup-stream 1)
(depict-semantic-keyword markup-stream 'end :after)
(depict-semantic-keyword markup-stream 'while nil)))
(defun depict-while (markup-stream world semicolon condition-annotated-expr &rest loop-annotated-stmts)
(depict-statement-block markup-stream
(depict-statement-block markup-stream
(depict-paragraph (markup-stream :statement)
(depict-semantic-keyword markup-stream 'while :after)
(depict-logical-block (markup-stream 4)
(depict-expression markup-stream world condition-annotated-expr %expr%))
(depict-semantic-keyword markup-stream 'do :before))
(depict-statements markup-stream world nil loop-annotated-stmts))
(depict-paragraph (markup-stream :statement)
(depict-semantic-keyword markup-stream 'end :after)
(depict-semantic-keyword markup-stream 'while nil)
(depict-semicolon markup-stream semicolon))))
; (assert <condition-expr>)
(defun depict-assert (markup-stream world condition-annotated-expr)
(depict-logical-block (markup-stream 4)
(depict-semantic-keyword markup-stream 'invariant :after)
(depict-expression markup-stream world condition-annotated-expr %expr%)))
(defun depict-assert (markup-stream world semicolon condition-annotated-expr)
(depict-paragraph (markup-stream :statement)
(depict-logical-block (markup-stream 4)
(depict-semantic-keyword markup-stream 'invariant :after)
(depict-expression markup-stream world condition-annotated-expr %expr%)
(depict-semicolon markup-stream semicolon))))
; (throw <value-expr>)
(defun depict-throw (markup-stream world value-annotated-expr)
(depict-logical-block (markup-stream 4)
(depict-semantic-keyword markup-stream 'throw :after)
(depict-expression markup-stream world value-annotated-expr %expr%)))
(defun depict-throw (markup-stream world semicolon value-annotated-expr)
(depict-paragraph (markup-stream :statement)
(depict-logical-block (markup-stream 4)
(depict-semantic-keyword markup-stream 'throw :after)
(depict-expression markup-stream world value-annotated-expr %expr%)
(depict-semicolon markup-stream semicolon))))
; (catch <body-statements> (<var> [:unused]) . <handler-statements>)
(defun depict-catch (markup-stream world body-annotated-stmts arg-binding-expr &rest handler-annotated-stmts)
(depict-logical-block (markup-stream 0)
(depict-logical-block (markup-stream 4)
(depict-semantic-keyword markup-stream 'try nil)
(depict-statements markup-stream world 1 body-annotated-stmts))
(depict-break markup-stream)
(depict-logical-block (markup-stream 4)
(defun depict-catch (markup-stream world semicolon body-annotated-stmts arg-binding-expr &rest handler-annotated-stmts)
(depict-statement-block markup-stream
(depict-paragraph (markup-stream :statement)
(depict-semantic-keyword markup-stream 'try nil))
(depict-statements markup-stream world nil body-annotated-stmts))
(depict-division-break markup-stream)
(depict-statement-block markup-stream
(depict-paragraph (markup-stream :statement)
(depict-semantic-keyword markup-stream 'catch :after)
(depict-logical-block (markup-stream 4)
(depict-local-variable markup-stream (first arg-binding-expr))
(depict markup-stream ": ")
(depict-type-expr markup-stream world *semantic-exception-type-name*))
(depict-semantic-keyword markup-stream 'do :before)
(depict-statements markup-stream world 1 handler-annotated-stmts))
(depict-break markup-stream)
(depict-semantic-keyword markup-stream 'do :before))
(depict-statements markup-stream world nil handler-annotated-stmts))
(depict-paragraph (markup-stream :statement)
(depict-semantic-keyword markup-stream 'end :after)
(depict-semantic-keyword markup-stream 'try nil)))
(depict-semantic-keyword markup-stream 'try nil)
(depict-semicolon markup-stream semicolon)))
; (case <value-expr> (key <type> . <statements>) ... (keyword <type> . <statements>))
@ -1085,47 +1083,118 @@
; :select No special action
; :narrow Narrow the type of <value-expr>, which must be a variable, to this case's <type>
; :otherwise Catch-all else case; <type> should be either nil or the remaining catch-all type
(defun depict-case (markup-stream world value-annotated-expr &rest annotated-cases)
(depict-logical-block (markup-stream 0)
(defun depict-case (markup-stream world semicolon value-annotated-expr &rest annotated-cases)
(depict-paragraph (markup-stream :statement)
(depict-semantic-keyword markup-stream 'case :after)
(depict-logical-block (markup-stream 8)
(depict-expression markup-stream world value-annotated-expr %expr%))
(depict-semantic-keyword markup-stream 'of :before)
(depict-list
markup-stream
#'(lambda (markup-stream annotated-case)
(depict-logical-block (markup-stream 4)
(ecase (first annotated-case)
((:select :narrow) (depict-type-expr markup-stream world (second annotated-case)))
((:otherwise) (depict-semantic-keyword markup-stream 'else nil)))
(depict-semantic-keyword markup-stream 'do :before)
(depict-statements markup-stream world 1 (cddr annotated-case))))
annotated-cases
:indent 4
:prefix-break t
:separator ";"
:break t
:empty nil)
(depict-break markup-stream)
(depict-semantic-keyword markup-stream 'of :before))
(depict-division-break markup-stream)
(depict-division-style (markup-stream :level)
(mapl #'(lambda (annotated-cases)
(let ((annotated-case (car annotated-cases)))
(depict-statement-block markup-stream
(depict-paragraph (markup-stream :statement)
(depict-logical-block (markup-stream 4)
(ecase (first annotated-case)
((:select :narrow) (depict-type-expr markup-stream world (second annotated-case)))
((:otherwise) (depict-semantic-keyword markup-stream 'else nil)))
(depict-semantic-keyword markup-stream 'do :before)))
(depict-statements markup-stream world (cdr annotated-cases) (cddr annotated-case)))))
annotated-cases))
(depict-paragraph (markup-stream :statement)
(depict-semantic-keyword markup-stream 'end :after)
(depict-semantic-keyword markup-stream 'case nil)))
(depict-semantic-keyword markup-stream 'case nil)
(depict-semicolon markup-stream semicolon)))
;;; ------------------------------------------------------------------------------------------------------
;;; DEPICTING FUNCTIONS
(defun depict-function-signature (markup-stream world arg-binding-exprs result-type-expr show-type)
(depict-logical-block (markup-stream 12)
(depict-list markup-stream
#'(lambda (markup-stream arg-binding)
(depict-local-variable markup-stream (first arg-binding))
(depict markup-stream ": ")
(depict-type-expr markup-stream world (second arg-binding)))
arg-binding-exprs
:indent 2
:prefix "("
:suffix ")"
:separator ","
:break 1
:empty nil)
(unless (or (eq result-type-expr 'void) (not show-type))
(depict markup-stream ":")
(depict-break markup-stream 1)
(depict-type-expr markup-stream world result-type-expr))))
; Depict the signature of a lambda annotated expression.
(defun depict-lambda-signature (markup-stream world type-expr lambda-annotated-expr show-type)
(declare (ignore type-expr))
(assert-true (special-form-annotated-expr? world 'lambda lambda-annotated-expr))
(depict-function-signature markup-stream world (third lambda-annotated-expr) (fourth lambda-annotated-expr) show-type))
; Return the list of body annotated statements of a lambda annotated expression.
(defun lambda-body-annotated-stmts (lambda-annotated-expr)
(cddddr lambda-annotated-expr))
; Return true if the function body given by body-annotated-stmts is a single return statement.
(defun function-body-is-expression? (world body-annotated-stmts)
(and body-annotated-stmts
(endp (cdr body-annotated-stmts))
(special-form-annotated-stmt? world 'return (first body-annotated-stmts))
(cdr (first body-annotated-stmts))))
; Depict a function's body as a series of divisions. markup-stream should be accepting divisions.
; If semicolon is true, depict a semicolon.
; Use last-paragraph-style for depicting the last paragraph.
(defun depict-function-body (markup-stream world semicolon last-paragraph-style body-annotated-stmts)
(if (function-body-is-expression? world body-annotated-stmts)
(depict-division-style (markup-stream :level)
(depict-paragraph (markup-stream last-paragraph-style)
(depict markup-stream :identical-10 " ")
(depict-expression markup-stream world (second (first body-annotated-stmts)) %expr%)
(depict-semicolon markup-stream semicolon)))
(progn
(depict-division-break markup-stream)
(when body-annotated-stmts
(depict-statements markup-stream world nil body-annotated-stmts))
(depict-paragraph (markup-stream last-paragraph-style)
(depict-semantic-keyword markup-stream 'end :after)
(depict-semantic-keyword markup-stream 'proc nil)
(depict-semicolon markup-stream semicolon)))))
;;; ------------------------------------------------------------------------------------------------------
;;; DEPICTING COMMANDS
(defmacro depict-semantics ((markup-stream depict-env &optional (paragraph-style :semantics)) &body body)
(defmacro depict-semantics ((markup-stream depict-env &optional (paragraph-style :algorithm-stmt)) &body body)
`(when (depict-mode ,markup-stream ,depict-env :semantics)
(depict-paragraph (,markup-stream ,paragraph-style)
,@body)))
(depict-division-style (,markup-stream :nowrap)
(depict-paragraph (,markup-stream ,paragraph-style)
,@body))))
(defmacro depict-algorithm ((markup-stream depict-env &optional (division-style :algorithm)) &body body)
`(when (depict-mode ,markup-stream ,depict-env :semantics)
(depict-division-style (,markup-stream :nowrap)
(depict-division-style (,markup-stream ,division-style)
,@body))))
; (%highlight <highlight> <command> ... <command>)
; Depict the commands highlighted with the <highlight> block style.
; Depict the commands highlighted with the <highlight> division style.
(defun depict-%highlight (markup-stream world depict-env highlight &rest commands)
(when commands
(depict-block-style (markup-stream highlight t)
(depict-division-style (markup-stream highlight t)
(depict-commands markup-stream world depict-env commands))))
@ -1267,28 +1336,29 @@
; (deftuple <name> (<name1> <type1>) ... (<namen> <typen>))
; (defrecord <name> (<name1> <type1>) ... (<namen> <typen>))
(defun depict-deftuple (markup-stream world depict-env name &rest fields)
(depict-semantics (markup-stream depict-env)
(depict-logical-block (markup-stream 2)
(let* ((type (scan-kinded-type world name :tag))
(tag (type-tag type))
(mutable (tag-mutable tag)))
(depict-semantic-keyword markup-stream (if mutable 'record 'tuple) :after)
(depict-type-name markup-stream name :definition)
(depict-list
markup-stream
#'(lambda (markup-stream field)
(depict-label-name markup-stream type (first field) nil)
(depict markup-stream ": ")
(depict-type-expr markup-stream world (second field) %%type%%))
fields
:indent 6
:prefix (if mutable :record-begin :tuple-begin)
:prefix-break 0
:suffix (if mutable :record-end :tuple-end)
:separator ","
:break 1
:empty nil))
(depict markup-stream ";"))))
(let* ((type (scan-kinded-type world name :tag))
(tag (type-tag type))
(mutable (tag-mutable tag))
(keyword (if mutable 'record 'tuple)))
(depict-algorithm (markup-stream depict-env)
(depict-paragraph (markup-stream :statement)
(depict-semantic-keyword markup-stream keyword :after)
(depict-type-name markup-stream name :definition))
(depict-division-style (markup-stream :level)
(mapl #'(lambda (fields)
(let ((field (car fields)))
(depict-paragraph (markup-stream :statement)
(depict-logical-block (markup-stream 4)
(depict-label-name markup-stream type (first field) nil)
(depict markup-stream ": ")
(depict-type-expr markup-stream world (second field) %%type%%)
(when (cdr fields)
(depict markup-stream ","))))))
fields))
(depict-paragraph (markup-stream :statement-last)
(depict-semantic-keyword markup-stream 'end :after)
(depict-semantic-keyword markup-stream keyword nil)
(depict markup-stream ";")))))
; (deftype <name> <type>)
@ -1296,53 +1366,71 @@
(depict-semantics (markup-stream depict-env)
(depict-logical-block (markup-stream 2)
(depict-type-name markup-stream name :definition)
(depict-break markup-stream 0)
(depict-break markup-stream 1)
(depict-logical-block (markup-stream 4)
(depict markup-stream " = ")
(depict markup-stream "= ")
(depict-type-expr markup-stream world type-expr))
(depict markup-stream ";"))))
(defun depict-type-and-value (markup-stream world type-expr value-annotated-expr show-type)
(when show-type
(depict-logical-block (markup-stream 4)
(depict markup-stream ":")
(depict-break markup-stream 1)
(depict-type-expr markup-stream world type-expr)))
(if (eq (car value-annotated-expr) 'expr-annotation:begin)
(depict-function-body markup-stream world (cdr value-annotated-expr))
(progn
(depict-break markup-stream 0)
(depict-logical-block (markup-stream 4)
(depict markup-stream " = ")
(depict-expression markup-stream world value-annotated-expr %expr%))))
(depict markup-stream ";"))
(defun depict-colon-and-type (markup-stream world type-expr)
(depict-logical-block (markup-stream 4)
(depict markup-stream ":")
(depict-break markup-stream 1)
(depict-type-expr markup-stream world type-expr)))
(defun depict-equals-and-value (markup-stream world value-annotated-expr)
(depict-break markup-stream 1)
(depict-logical-block (markup-stream 4)
(depict markup-stream "= ")
(depict-expression markup-stream world value-annotated-expr %expr%)
(depict markup-stream ";")))
(defun depict-begin (markup-stream world value-annotated-expr)
(assert-true (eq (car value-annotated-expr) 'expr-annotation:begin))
(depict-division-style (markup-stream :level)
(depict-paragraph (markup-stream :statement)
(depict-semantic-keyword markup-stream 'begin nil))
(let ((annotated-stmts (cdr value-annotated-expr)))
(when annotated-stmts
(depict-statements markup-stream world nil annotated-stmts)))
(depict-paragraph (markup-stream :statement-last)
(depict-semantic-keyword markup-stream 'end nil)
(depict markup-stream ";"))))
; (define <name> <type> <value>)
(defun depict-define (markup-stream world depict-env name type-expr value-expr)
(depict-semantics (markup-stream depict-env)
(depict-logical-block (markup-stream 0)
(depict-global-variable markup-stream name :definition)
(let ((value-annotated-expr (nth-value 2 (scan-value world *null-type-env* value-expr))))
(depict-type-and-value markup-stream world type-expr value-annotated-expr t)))))
(let ((value-annotated-expr (nth-value 2 (scan-value world *null-type-env* value-expr))))
(if (eq (car value-annotated-expr) 'expr-annotation:begin)
(depict-algorithm (markup-stream depict-env)
(depict-paragraph (markup-stream :statement)
(depict-logical-block (markup-stream 0)
(depict-global-variable markup-stream name :definition)
(depict-colon-and-type markup-stream world type-expr)))
(depict-begin markup-stream world value-annotated-expr))
(depict-semantics (markup-stream depict-env)
(depict-logical-block (markup-stream 0)
(depict-global-variable markup-stream name :definition)
(depict-colon-and-type markup-stream world type-expr)
(depict-equals-and-value markup-stream world value-annotated-expr))))))
(defun depict-signature-and-body (markup-stream world type-expr value-annotated-expr show-type)
(declare (ignore type-expr))
(assert-true (special-form-annotated-expr? world 'lambda value-annotated-expr))
(depict-function-signature markup-stream world (third value-annotated-expr) (fourth value-annotated-expr) show-type)
(depict-function-body markup-stream world (cddddr value-annotated-expr))
(depict markup-stream ";"))
; (defun <name> (-> (<type1> ... <typen>) <result-type>) (lambda ((<arg1> <type1>) ... (<argn> <typen>)) <result-type> . <statements>))
(defun depict-defun (markup-stream world depict-env name type-expr value-expr)
(assert-true (eq (first type-expr) '->))
(let ((value-annotated-expr (nth-value 2 (scan-value world *null-type-env* value-expr))))
(depict-semantics (markup-stream depict-env)
(depict-logical-block (markup-stream 0)
(depict-semantic-keyword markup-stream 'function :after)
(depict-global-variable markup-stream name :definition)
(depict-signature-and-body markup-stream world type-expr value-annotated-expr t)))))
(let* ((value-annotated-expr (nth-value 2 (scan-value world *null-type-env* value-expr)))
(body-annotated-stmts (lambda-body-annotated-stmts value-annotated-expr)))
(depict-algorithm (markup-stream depict-env)
(depict-statement-block-last markup-stream
(depict-paragraph (markup-stream :statement)
(depict-semantic-keyword markup-stream 'proc :after)
(depict-global-variable markup-stream name :definition)
(depict-lambda-signature markup-stream world type-expr value-annotated-expr t))
(depict-function-body markup-stream world t :statement-last body-annotated-stmts)))))
; (set-grammar <name>)
@ -1377,10 +1465,10 @@
(defmacro depict-delayed-action ((markup-stream depict-env) &body depictor)
(let ((saved-block-style (gensym "SAVED-BLOCK-STYLE")))
`(let ((,saved-block-style (save-block-style ,markup-stream)))
(let ((saved-division-style (gensym "SAVED-DIVISION-STYLE")))
`(let ((,saved-division-style (save-division-style ,markup-stream)))
(push #'(lambda (,markup-stream ,depict-env)
(with-saved-block-style (,markup-stream ,saved-block-style t) ,@depictor))
(with-saved-division-style (,markup-stream ,saved-division-style t) ,@depictor))
(depict-env-pending-actions-reverse ,depict-env)))))
@ -1389,9 +1477,9 @@
(depict markup-stream :action-begin)
(depict-general-grammar-symbol markup-stream general-grammar-symbol :reference)
(depict markup-stream :action-end)
(depict-break markup-stream 0)
(depict-logical-block (markup-stream 2)
(depict markup-stream ": ")
(depict markup-stream ":")
(depict-break markup-stream 1)
(depict-type-expr markup-stream world type-expr)))
@ -1403,7 +1491,7 @@
(grammar-info-charclass-or-partition grammar-info general-grammar-symbol)
(= n-productions 1))
(depict-delayed-action (markup-stream depict-env)
(depict-semantics (markup-stream depict-env)
(depict-semantics (markup-stream depict-env :algorithm-stmt-narrow)
(depict-logical-block (markup-stream 4)
(depict-declare-action-contents markup-stream world action-name general-grammar-symbol type-expr)
(depict markup-stream ";")))))))
@ -1436,6 +1524,12 @@
(defun depict-actfun (markup-stream world depict-env action-name production-name type-expr n-productions value-expr)
(depict-general-action markup-stream world depict-env action-name production-name type-expr n-productions value-expr t))
(defun depict-action-signature (markup-stream action-name general-production action-grammar-symbols)
(depict-action-name markup-stream action-name)
(depict markup-stream :action-begin)
(depict-general-production markup-stream general-production :reference action-grammar-symbols)
(depict markup-stream :action-end))
(defun depict-general-action (markup-stream world depict-env action-name production-name type-expr n-productions value-expr destructured)
(let* ((grammar-info (checked-depict-env-grammar-info depict-env))
(grammar (grammar-info-grammar grammar-info))
@ -1445,19 +1539,36 @@
(unless (or (grammar-info-charclass grammar-info lhs)
(hidden-nonterminal? lhs))
(depict-delayed-action (markup-stream depict-env)
(depict-semantics (markup-stream depict-env (if show-type :semantics :semantics-next))
(depict-logical-block (markup-stream 0)
(let* ((initial-env (general-production-action-env grammar general-production))
(type (scan-type world type-expr))
(value-annotated-expr (nth-value 1 (scan-typed-value-or-begin world initial-env value-expr type)))
(action-grammar-symbols (annotated-expr-grammar-symbols value-annotated-expr)))
(depict-action-name markup-stream action-name)
(depict markup-stream :action-begin)
(depict-general-production markup-stream general-production :reference action-grammar-symbols)
(depict markup-stream :action-end)
(if destructured
(depict-signature-and-body markup-stream world type-expr value-annotated-expr show-type)
(depict-type-and-value markup-stream world type-expr value-annotated-expr show-type)))))))))
(let* ((initial-env (general-production-action-env grammar general-production))
(type (scan-type world type-expr))
(value-annotated-expr (nth-value 1 (scan-typed-value-or-begin world initial-env value-expr type)))
(action-grammar-symbols (annotated-expr-grammar-symbols value-annotated-expr)))
(if destructured
(let ((body-annotated-stmts (lambda-body-annotated-stmts value-annotated-expr)))
(depict-algorithm (markup-stream depict-env (if show-type :algorithm :algorithm-next))
(depict-statement-block-last markup-stream
(depict-paragraph (markup-stream :statement)
(depict-logical-block (markup-stream 0)
(depict-semantic-keyword markup-stream 'proc :after)
(depict-action-signature markup-stream action-name general-production action-grammar-symbols)
(depict-break markup-stream 1)
(depict-lambda-signature markup-stream world type-expr value-annotated-expr show-type)))
(depict-function-body markup-stream world t :statement-last body-annotated-stmts))))
(if (eq (car value-annotated-expr) 'expr-annotation:begin)
(depict-algorithm (markup-stream depict-env (if show-type :algorithm :algorithm-next))
(depict-paragraph (markup-stream :statement)
(depict-logical-block (markup-stream 0)
(depict-action-signature markup-stream action-name general-production action-grammar-symbols)
(when show-type
(depict-colon-and-type markup-stream world type-expr))))
(depict-begin markup-stream world value-annotated-expr))
(depict-semantics (markup-stream depict-env (if show-type :algorithm-stmt :algorithm-next-stmt))
(depict-logical-block (markup-stream 0)
(depict-action-signature markup-stream action-name general-production action-grammar-symbols)
(when show-type
(depict-colon-and-type markup-stream world type-expr))
(depict-equals-and-value markup-stream world value-annotated-expr))))))))))
; (terminal-action <action-name> <terminal> <lisp-function>)

23
js2/semantics/Grammar.lisp
Просмотреть файл

@ -473,17 +473,18 @@
(let* ((production-runs (gather-productions-by-highlights general-productions))
(rule-highlight (and (endp (rest production-runs))
(check-highlight (first (first production-runs)) highlights markup-stream))))
(depict-block-style (markup-stream rule-highlight t)
(depict-block-style (markup-stream :grammar-rule)
(if (rest general-productions)
(progn
(depict-general-production-lhs markup-stream (general-rule-lhs general-rule))
(dolist (production-run production-runs)
(depict-block-style (markup-stream (check-highlight (first production-run) highlights markup-stream) t)
(dolist (p (rest production-run))
(apply #'depict-general-production-rhs markup-stream p)))))
(depict-paragraph (markup-stream :grammar-lhs-last)
(depict-general-production markup-stream (first general-productions) :definition))))))))
(depict-division-style (markup-stream rule-highlight t)
(depict-division-style (markup-stream :nowrap)
(depict-division-style (markup-stream :grammar-rule)
(if (rest general-productions)
(progn
(depict-general-production-lhs markup-stream (general-rule-lhs general-rule))
(dolist (production-run production-runs)
(depict-division-style (markup-stream (check-highlight (first production-run) highlights markup-stream) t)
(dolist (p (rest production-run))
(apply #'depict-general-production-rhs markup-stream p)))))
(depict-paragraph (markup-stream :grammar-lhs-last)
(depict-general-production markup-stream (first general-productions) :definition)))))))))
;;; ------------------------------------------------------------------------------------------------------

4
js2/semantics/HTML-To-RTF/Convert.lisp
Просмотреть файл

@ -475,7 +475,7 @@
title
#'(lambda (markup-stream)
(emit-html-file markup-stream element))
*html-to-rtf-definitions*)))
*rtf-definitions*)))
#|
(setq s (html-parser:file->string "Huit:Mozilla:Docs:mozilla-org:html:js:language:js20:formal:index.html"))
@ -486,7 +486,7 @@
"Test"
#'(lambda (markup-stream)
(emit-html-file markup-stream p))
*html-to-rtf-definitions*)
*rtf-definitions*)
(translate-html-to-rtf "Huit:Mozilla:Docs:mozilla-org:html:js:language:js20:formal:index.html" "HTML-To-RTF/Test.rtf" "Test")
(translate-html-to-rtf "Huit:Mozilla:Docs:mozilla-org:html:js:language:js20:introduction:notation.html"

147
js2/semantics/HTML.lisp
Просмотреть файл

@ -133,12 +133,13 @@
(nreverse html-sources))))
; Escape all content strings in the html-source, while interpreting :nowrap, :wrap, and :none pseudo-tags.
; Escape all content strings in the html-source, while interpreting :nowrap, :wrap, :space, 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))
((eq html-source :space) (list 'space))
((or (characterp html-source) (symbolp html-source) (integerp html-source))
(list html-source))
((consp html-source)
@ -153,7 +154,7 @@
(t (error "Bad html-source: ~S" html-source))))
; Escape all content strings in the html-source, while interpreting :nowrap, :wrap, and :none pseudo-tags.
; Escape all content strings in the html-source, while interpreting :nowrap, :wrap, :space, and :none pseudo-tags.
(defun escape-html (html-source)
(let ((results (escape-html-source html-source 'space)))
(assert-true (= (length results) 1))
@ -168,6 +169,7 @@
;; <symbol> ;Named entity
;; <integer> ;Numbered entity
;; space ;Space or newline
;; :space ;Breaking space, regardless of enclosing :nowrap tags
;; (<tag> <html-source> ... <html-source>) ;Tag and its contents
;; ((:nest <tag> ... <tag>) <html-source> ... <html-source>) ;Equivalent to (<tag> (... (<tag> <html-source> ... <html-source>)))
;;
@ -186,10 +188,11 @@
(defparameter *html-right-margin* 120)
(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
(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-indent*) ;Indent to use for emit-html-newlines-and-indent calls
(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-pending-indent*) ;Indent to use if *current-html-pending* is placed on a new line
(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.
@ -227,8 +230,9 @@
(concatenate 'string *current-html-pending* html-string)))
(when (>= (+ *current-html-pos* (length *current-html-pending*)) *html-right-margin*)
(write-char #\newline stream)
(write-string (make-string *current-html-pending-indent* :initial-element #\space) stream)
(write-string *current-html-pending* stream)
(setq *current-html-pos* (length *current-html-pending*))
(setq *current-html-pos* (+ *current-html-pending-indent* (length *current-html-pending*)))
(setq *current-html-pending* nil)))
(progn
(write-string html-string stream)
@ -283,7 +287,8 @@
((eq html-source 'space)
(when (zerop *current-html-newlines*)
(flush-current-html-pending stream)
(setq *current-html-pending* "")))
(setq *current-html-pending* "")
(setq *current-html-pending-indent* *current-html-indent*)))
((or (characterp html-source) (symbolp html-source))
(let ((entity-name (gethash html-source *html-entities-hash*)))
(cond
@ -311,8 +316,9 @@
(*print-escape* nil)
(*print-case* :upcase)
(*current-html-pos* nil)
(*current-html-pending* nil)
(*current-html-indent* 0)
(*current-html-pending* nil)
(*current-html-pending-indent* nil)
(*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)
@ -390,7 +396,6 @@
'(((:new-line t) (br))
;Misc.
(:spc nbsp)
(:tab2 nbsp nbsp)
(:tab3 nbsp nbsp nbsp)
(:nbhy "-") ;Non-breaking hyphen
@ -460,22 +465,28 @@
((:psi 1) (:script "document.write(U_psi)"))
((:zeta 1) (:script "document.write(U_zeta)"))
;Block Styles
;Division 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-rule (div (class "grammar-rule")))
(:grammar-lhs (div (class "grammar-lhs")))
(:grammar-lhs-last :grammar-lhs)
(:grammar-rhs (:nest :nowrap (div (class "grammar-rhs"))))
(:grammar-rhs (div (class "grammar-rhs")))
(:grammar-rhs-last :grammar-rhs)
(:grammar-argument (:nest :nowrap (div (class "grammar-argument"))))
(:semantics (:nest :nowrap (div (class "semantics"))))
(:semantics-next (:nest :nowrap (div (class "semantics-next"))))
(:semantic-comment (div (class "semantic-comment")))
(:algorithm (div (class "algorithm")))
(:algorithm-next (div (class "algorithm-next")))
(:algorithm-stmt (div (class "algorithm-stmt")))
(:algorithm-stmt-narrow :algorithm-stmt)
(:algorithm-next-stmt (div (class "algorithm-next-stmt")))
((:level 4) (div (class "lvl")))
(:statement (div (class "stmt")))
(:statement-last :statement)
;Inline Styles
(:script (script (type "text/javascript")))
@ -527,7 +538,8 @@
;;; HTML STREAMS
(defstruct (html-stream (:include markup-stream)
(:constructor allocate-html-stream (env head tail level logical-position enclosing-styles anchors))
(:constructor allocate-html-stream (env head tail level logical-line-width division-length logical-position
enclosing-styles anchors))
(:copier nil)
(:predicate html-stream?))
(enclosing-styles nil :type list :read-only t) ;A list of enclosing styles
@ -541,9 +553,9 @@
; 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)
(defun make-html-stream (markup-env level logical-line-width division-length logical-position enclosing-styles anchors)
(let ((head (list nil)))
(allocate-html-stream markup-env head head level logical-position enclosing-styles anchors)))
(allocate-html-stream markup-env head head level logical-line-width division-length logical-position enclosing-styles anchors)))
; Make a new, empty, open, top-level html-stream with the given definitions
@ -552,7 +564,7 @@
(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)))
(allocate-html-stream markup-env head head *markup-stream-top-level* *markup-logical-line-width* nil nil nil nil)))
; Return the approximate width of the html item; return t if it is a line break.
@ -569,12 +581,12 @@
(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)
(depict-division-style (html-stream 'head)
(depict-division-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)
(depict-division-style (html-stream 'body)
(funcall emitter html-stream))
(let ((links (markup-env-links (html-stream-env html-stream))))
(warn-missing-links links))
@ -600,43 +612,96 @@
(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)))))
(markup-env-expand (markup-stream-env html-stream) (markup-stream-unexpanded-output html-stream) '(:none :nowrap :wrap :space :nest)))))
(defmethod depict-block-style-f ((html-stream html-stream) block-style flatten emitter)
(defmethod depict-division-style-f ((html-stream html-stream) division-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))))
(assert-true (symbolp division-style))
(if (or (null division-style)
(and flatten (member division-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*
(- (html-stream-logical-line-width html-stream) (markup-width html-stream division-style))
0
nil
(cons block-style (html-stream-enclosing-styles html-stream))
(cons division-style (html-stream-enclosing-styles html-stream))
nil)))
(markup-stream-append1 inner-html-stream block-style)
(markup-stream-append1 inner-html-stream division-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)))))))
(markup-stream-append1 html-stream inner-output)
(increment-division-length html-stream (html-stream-division-length inner-html-stream))))))))
; html is the output from an html-stream consisting of paragraphs and/or divisions. Every
; division must be one of the given division-styles and may contain other such divisions and/or
; paragraphs. All paragraphs must have paragraph styles that are members of the paragraph-styles list.
; Return html flattened to a single paragraph with the given paragraph-style with spaces inserted
; between the component paragraphs. May destroy the original html list.
(defun flatten-division-block (html paragraph-style paragraph-styles division-styles)
(labels ((flatten-item (html-item)
(let ((tag (first html-item))
(contents (rest html-item)))
(cond
((member tag paragraph-styles) (cons " " contents))
((member tag division-styles :test #'eq)
(mapcan #'flatten-item contents))
(t (error "Unable to flatten ~S" html-item))))))
(if html
(list (cons paragraph-style (cdr (mapcan #'flatten-item html))))
nil)))
(defmethod depict-division-block-f ((html-stream html-stream) paragraph-style paragraph-styles division-styles emitter)
(assert-true (<= (markup-stream-level html-stream) *markup-stream-paragraph-level*))
(assert-true (and paragraph-style (symbolp paragraph-style)))
(let* ((logical-line-width (html-stream-logical-line-width html-stream))
(inner-html-stream (make-html-stream (markup-stream-env html-stream)
*markup-stream-paragraph-level*
logical-line-width
0
nil
(html-stream-enclosing-styles html-stream)
nil)))
(prog1
(funcall emitter inner-html-stream)
(let ((inner-output (markup-stream-unexpanded-output inner-html-stream))
(inner-length (html-stream-division-length inner-html-stream)))
(unless (eq inner-length t)
(if (> inner-length logical-line-width)
(setq inner-length t)
(setq inner-output (flatten-division-block inner-output paragraph-style paragraph-styles division-styles))))
(increment-division-length html-stream inner-length)
(markup-stream-append-list 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))
(logical-position (make-logical-position))
(inner-html-stream (make-html-stream (markup-stream-env html-stream)
*markup-stream-content-level*
(make-logical-position)
(- (html-stream-logical-line-width html-stream) (markup-width html-stream paragraph-style))
nil
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)))))))
(markup-stream-unexpanded-output inner-html-stream))))
(assert-true (and (eq logical-position (html-stream-logical-position inner-html-stream))
(null (logical-position-n-soft-breaks logical-position))))
(increment-division-length html-stream (if (= (logical-position-n-hard-breaks logical-position) 0)
(1+ (logical-position-position logical-position))
t)))))
(defmethod depict-char-style-f ((html-stream html-stream) char-style emitter)
@ -646,6 +711,8 @@
(assert-true (symbolp char-style))
(let ((inner-html-stream (make-html-stream (markup-stream-env html-stream)
*markup-stream-content-level*
(html-stream-logical-line-width html-stream)
nil
(markup-stream-logical-position html-stream)
(cons char-style (html-stream-enclosing-styles html-stream))
(html-stream-anchors html-stream))))
@ -661,17 +728,17 @@
(cerror "Ignore" "Style ~S should not be in effect" style)))
(defmethod save-block-style ((html-stream html-stream))
(defmethod save-division-style ((html-stream html-stream))
(reverse (html-stream-enclosing-styles html-stream)))
(defmethod with-saved-block-style-f ((html-stream html-stream) saved-block-style flatten emitter)
(defmethod with-saved-division-style-f ((html-stream html-stream) saved-division-style flatten emitter)
(assert-true (<= (markup-stream-level html-stream) *markup-stream-paragraph-level*))
(if (endp saved-block-style)
(if (endp saved-division-style)
(funcall emitter html-stream)
(depict-block-style-f html-stream (first saved-block-style) flatten
#'(lambda (html-stream)
(with-saved-block-style-f html-stream (rest saved-block-style) flatten emitter)))))
(depict-division-style-f html-stream (first saved-division-style) flatten
#'(lambda (html-stream)
(with-saved-division-style-f html-stream (rest saved-division-style) flatten emitter)))))
(defmethod depict-anchor ((html-stream html-stream) link-prefix link-name duplicate)
@ -689,6 +756,8 @@
(if href
(let ((inner-html-stream (make-html-stream (markup-stream-env html-stream)
*markup-stream-content-level*
(html-stream-logical-line-width html-stream)
nil
(markup-stream-logical-position html-stream)
(html-stream-enclosing-styles html-stream)
(html-stream-anchors html-stream))))

2
js2/semantics/JS20/Parser.lisp
Просмотреть файл

@ -2210,7 +2210,7 @@
(when bin-terminals
(depict-paragraph (markup-stream :body-text)
(depict markup-stream bin-name)
(depict-list markup-stream #'depict-terminal bin-terminals :separator '(" " :spc " "))))))
(depict-list markup-stream #'depict-terminal bin-terminals :separator " ")))))
(let* ((bins (make-array 6 :initial-element nil))
(all-terminals (grammar-terminals grammar))

39
js2/semantics/Lexer.lisp
Просмотреть файл

@ -308,25 +308,26 @@
; Emit markup paragraphs for the lexer charclass.
(defun depict-charclass (markup-stream charclass)
(depict-block-style (markup-stream :grammar-rule)
(let ((nonterminal (charclass-nonterminal charclass))
(expr (charclass-charset-source charclass)))
(if (and (consp expr) (eq (first expr) '++))
(let* ((subexprs (rest expr))
(length (length subexprs)))
(depict-paragraph (markup-stream :grammar-lhs)
(depict-general-nonterminal markup-stream nonterminal :definition)
(depict markup-stream " " :derives-10))
(dotimes (i length)
(depict-paragraph (markup-stream (if (= i (1- length)) :grammar-rhs-last :grammar-rhs))
(if (zerop i)
(depict markup-stream :tab3)
(depict markup-stream "|" :tab2))
(depict-charset-source markup-stream (nth i subexprs)))))
(depict-paragraph (markup-stream :grammar-lhs-last)
(depict-general-nonterminal markup-stream (charclass-nonterminal charclass) :definition)
(depict markup-stream " " :derives-10 " ")
(depict-charset-source markup-stream expr))))))
(depict-division-style (markup-stream :nowrap)
(depict-division-style (markup-stream :grammar-rule)
(let ((nonterminal (charclass-nonterminal charclass))
(expr (charclass-charset-source charclass)))
(if (and (consp expr) (eq (first expr) '++))
(let* ((subexprs (rest expr))
(length (length subexprs)))
(depict-paragraph (markup-stream :grammar-lhs)
(depict-general-nonterminal markup-stream nonterminal :definition)
(depict markup-stream " " :derives-10))
(dotimes (i length)
(depict-paragraph (markup-stream (if (= i (1- length)) :grammar-rhs-last :grammar-rhs))
(if (zerop i)
(depict markup-stream :tab3)
(depict markup-stream "|" :tab2))
(depict-charset-source markup-stream (nth i subexprs)))))
(depict-paragraph (markup-stream :grammar-lhs-last)
(depict-general-nonterminal markup-stream (charclass-nonterminal charclass) :definition)
(depict markup-stream " " :derives-10 " ")
(depict-charset-source markup-stream expr)))))))
;;; ------------------------------------------------------------------------------------------------------

86
js2/semantics/Markup.lisp
Просмотреть файл

@ -30,6 +30,8 @@
(defvar *markup-logical-line-width* 90) ;Approximate maximum number of characters to display on a single logical line
(defvar *average-space-width* 2/3) ;Width of a space as a percentage of average character width when calculating logical line widths
(defvar *compact-breaks* t) ;If true, all hard breaks are replaced by spaces and there is no indentation
(defvar *external-link-base* nil) ;URL prefix for referring to a page with external links or nil if none
@ -231,9 +233,11 @@
; Return a freshly consed markup list for a hard line break followed by indent spaces.
(defun hard-break-markup (indent)
(if (zerop indent)
(list :new-line)
(list :new-line (make-string indent :initial-element #\space :element-type #-mcl 'character #+mcl 'base-character))))
(cond
(*compact-breaks* (list :space))
((zerop indent) (list :new-line))
(t (list :new-line (make-string indent :initial-element #\space :element-type #-mcl 'character #+mcl 'base-character)))))
; Destructively replace any soft-break that appears in a car position in the tree
@ -258,6 +262,8 @@
; ; A markup-stream may destructively modify any sublists of head that contain a soft-break.
(tail nil :type list) ;Last cons cell of the output list; new cells are added in place to this cell's cdr; nil after markup-stream is closed.
(pretail nil :type list) ;Tail's predecessor if tail's car is a block that can be inlined at the end of the output list; nil otherwise.
(logical-line-width 0 :type integer);Logical line width for the current paragraph
(division-length nil) ;Number of characters in the current division block; t if more than one line; nil if not emitting division block.
(logical-position nil :type logical-position)) ;Information about the current logical lines or nil if not emitting paragraph contents
; ;RTF ;HTML
@ -267,6 +273,15 @@
(defconstant *markup-stream-content-level* 3) ;Paragraph contents ;Inline tags
; Add additional-length to this markup-stream's division-length. additional-length may be t, which sets
; division-length to t. division-length is left alone if it was nil.
(defun increment-division-length (markup-stream additional-length)
(cond
((not (numberp (markup-stream-division-length markup-stream))))
((eq additional-length t) (setf (markup-stream-division-length markup-stream) t))
(t (incf (markup-stream-division-length markup-stream) additional-length))))
; Return the markup accumulated in the markup-stream.
; The markup-stream is closed after this function is called.
(defun markup-stream-unexpanded-output (markup-stream)
@ -291,6 +306,16 @@
(setf (markup-stream-tail markup-stream) item-cons)))
; Append a list of items to the end of the markup-stream.
; The list becomes part of the markup-stream's structure and will be mutated by subsequent operations
; on the markup-stream.
(defun markup-stream-append-list (markup-stream items)
(when items
(setf (markup-stream-pretail markup-stream) nil)
(setf (cdr (markup-stream-tail markup-stream)) items)
(setf (markup-stream-tail markup-stream) (last items))))
; Return the approximate width of the markup item; return t if it is a line break.
(defun markup-width (markup-stream item)
(cond
@ -340,16 +365,39 @@
; markup-stream must be a variable that names a markup-stream that is currently
; accepting paragraphs. Execute body with markup-stream bound to a markup-stream
; to which the body can emit contents. If non-null, the given block-style is applied to all
; paragraphs emitted by body (in the HTML emitter only; RTF has no block styles).
; If flatten is true, do not emit the style if it is already in effect from a surrounding block
; to which the body can emit contents. If non-null, the given division-style is applied to all
; paragraphs emitted by body.
; If flatten is true, do not emit the style if it is already in effect from a surrounding division
; or if its contents are empty.
; Return the result value of body.
(defmacro depict-block-style ((markup-stream block-style &optional flatten) &body body)
`(depict-block-style-f ,markup-stream ,block-style ,flatten
#'(lambda (,markup-stream) ,@body)))
(defmacro depict-division-style ((markup-stream division-style &optional flatten) &body body)
`(depict-division-style-f ,markup-stream ,division-style ,flatten
#'(lambda (,markup-stream) ,@body)))
(defgeneric depict-division-style-f (markup-stream division-style flatten emitter))
; markup-stream must be a variable that names a markup-stream that is currently
; accepting paragraphs. Execute body with markup-stream bound to a markup-stream
; to which the body can emit divisions and paragraphs. If everything the body emits
; could fit on one line, collapse out any sub-divisions whose styles are a member of the
; division-styles list. The result should be zero or more paragraphs all having
; paragraph styles that are members of the paragraph-styles list; coalesce them into a single
; paragraph with style paragraph-style.
; Return the result value of body.
(defmacro depict-division-block ((markup-stream paragraph-style paragraph-styles division-styles) &body body)
`(depict-division-block-f ,markup-stream ,paragraph-style ,paragraph-styles ,division-styles
#'(lambda (,markup-stream) ,@body)))
(defgeneric depict-division-block-f (markup-stream paragraph-style paragraph-styles division-styles emitter))
; Prevent any enclosing depict-division-block from collapsing its contents.
(defun depict-division-break (markup-stream)
(assert-true (<= (markup-stream-level markup-stream) *markup-stream-paragraph-level*))
(when (numberp (markup-stream-division-length markup-stream))
(setf (markup-stream-division-length markup-stream) t)))
(defgeneric depict-block-style-f (markup-stream block-style flatten emitter))
; markup-stream must be a variable that names a markup-stream that is currently
@ -381,22 +429,22 @@
(defgeneric ensure-no-enclosing-style (markup-stream style))
; Return a value that captures the current sequence of enclosing block styles.
(defgeneric save-block-style (markup-stream))
; Return a value that captures the current sequence of enclosing division styles.
(defgeneric save-division-style (markup-stream))
; markup-stream must be a variable that names a markup-stream that is currently
; accepting paragraphs. Execute body with markup-stream bound to a markup-stream
; to which the body can emit contents. The given saved-block-style is applied to all
; paragraphs emitted by body (in the HTML emitter only; RTF has no block styles).
; saved-block-style should have been obtained from a past call to save-block-style.
; to which the body can emit contents. The given saved-division-style is applied to all
; paragraphs emitted by body (in the HTML emitter only; RTF has no division styles).
; saved-division-style should have been obtained from a past call to save-division-style.
; If flatten is true, do not emit the style if it is already in effect from a surrounding block
; or if its contents are empty.
; Return the result value of body.
(defmacro with-saved-block-style ((markup-stream saved-block-style &optional flatten) &body body)
`(with-saved-block-style-f ,markup-stream ,saved-block-style ,flatten
(defmacro with-saved-division-style ((markup-stream saved-division-style &optional flatten) &body body)
`(with-saved-division-style-f ,markup-stream ,saved-division-style ,flatten
#'(lambda (,markup-stream) ,@body)))
(defgeneric with-saved-block-style-f (markup-stream saved-block-style flatten emitter))
(defgeneric with-saved-division-style-f (markup-stream saved-division-style flatten emitter))
; Depict an anchor. The concatenation of link-prefix and link-name must be a string
@ -477,7 +525,7 @@
(incf (logical-position-n-hard-breaks logical-position) inner-n-hard-breaks)
(setf (logical-position-position logical-position) inner-position)
(setf (logical-position-surplus logical-position) 0))))
((and (zerop inner-n-hard-breaks) (<= inner-position *markup-logical-line-width*))
((and (zerop inner-n-hard-breaks) (<= inner-position (markup-stream-logical-line-width markup-stream)))
(assert-true tree)
(remove-soft-breaks tree)
(incf (logical-position-position logical-position) inner-count))

796
js2/semantics/RTF.lisp
Просмотреть файл

@ -96,341 +96,7 @@
;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)
(:14-pt fs 28)
(: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)
((:apostrophe 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)
((:for-all-10 1) (field (* fldinst "SYMBOL 34 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
((:exists-10 1) (field (* fldinst "SYMBOL 36 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
((:bottom-10 1) (field (* fldinst "SYMBOL 94 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
((: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)))
((:subset-10 2) (field (* fldinst "SYMBOL 204 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
((:subset-eq-10 2) (field (* fldinst "SYMBOL 205 \\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)))
((:label-assign-10 2) (field (* fldinst "SYMBOL 220 \\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)))
((:left-ceiling-10 1) (field (* fldinst "SYMBOL 233 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
((:left-floor-10 1) (field (* fldinst "SYMBOL 235 \\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)))
((:right-ceiling-10 1) (field (* fldinst "SYMBOL 249 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
((:right-floor-10 1) (field (* fldinst "SYMBOL 251 \\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;"))
(: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;"))
(: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 :navy)
((+ :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 :maroon :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-name-num 41)
(:type-name cs :type-name-num scaps :times :red :no-language)
((+ :styles) (* :type-name additive sbasedon :default-paragraph-font-num "Type Name;"))
(:field-name-num 42)
(:field-name cs :field-name-num :helvetica :no-language)
((+ :styles) (* :field-name additive sbasedon :default-paragraph-font-num "Field Name;"))
(:tag-name-num 43)
(:tag-name cs :tag-name-num :helvetica b :no-language)
((+ :styles) (* :tag-name additive sbasedon :default-paragraph-font-num "Tag Name;"))
(:global-variable-num 44)
(:global-variable cs :global-variable-num i :times :dark-green :no-language)
((+ :styles) (* :global-variable additive sbasedon :default-paragraph-font-num "Global Variable;"))
(:variable-num 45)
(:variable cs :variable-num i :times :color336600 :no-language)
((+ :styles) (* :variable additive sbasedon :default-paragraph-font-num "Variable;"))
(:local-variable :variable)
(:action-name-num 46)
(:action-name cs :action-name-num :zapf-chancery :purple :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-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))
((:record-begin 1) (b :left-triangle-bracket-10 :left-triangle-bracket-10))
((:record-end 1) (b :right-triangle-bracket-10 :right-triangle-bracket-10))
((:true 4) (:global-variable "true"))
((:false 5) (:global-variable "false"))
((:unique 6) (:semantic-keyword "unique"))
))
(defparameter *html-to-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
red 0 green 64 blue 0 ";" ;17
red #x33 green #x66 blue #x00 ";"));18
(:black cf 1)
(:blue cf 2)
(:aqua cf 3)
(:lime cf 4)
(:fuchsia cf 5)
(:red cf 6)
(:yellow cf 7)
(:white cf 8)
(:navy cf 9)
(:teal cf 10)
(:green cf 11)
(:purple cf 12)
(:maroon cf 13)
(:olive cf 14)
(:gray cf 15)
(:silver cf 16)
(:dark-green cf 17)
(:color336600 cf 18)
;Misc.
(:spc " ")
(:space " ")
(:tab2 tab)
(:tab3 tab)
(:nbhy _) ;Non-breaking hyphen
@ -522,62 +188,119 @@
;Styles
((+ :rtf-intro) :stylesheet)
(:stylesheet (stylesheet :styles))
(:asian-keywords aspalpha aspnum faauto)
(:normal-num 0)
(:normal s :normal-num)
((+ :styles) (widctlpar :10-pt :english snext :normal-num "Normal;"))
((+ :styles) (widctlpar :asian-keywords :10-pt :english snext :normal-num "Normal;"))
(:body-text-num 1)
(:body-text s :body-text-num qj sa 120 widctlpar :10-pt :english)
(:body-text s :body-text-num qj sa 180 widctlpar :asian-keywords :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)
(:body-text-narrow-num 2)
(:body-text-narrow s :body-text-narrow-num qj sa 40 widctlpar :asian-keywords :10-pt :english)
((+ :styles) (:body-text-narrow sbasedon :body-text-num snext :body-text-narrow-num "Body Text Narrow;"))
(:semantic-comment :body-text-narrow)
(:header-num 5)
(:header s :header-num nowidctlpar :asian-keywords tqr tx 10080 :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)
(:footer-num 6)
(:footer s :footer-num nowidctlpar :asian-keywords tqc tx 5040 :10-pt :english)
((+ :styles) (:footer sbasedon :normal-num snext :footer-num "footer;"))
(:grammar-num 10)
(:grammar s :grammar-num nowidctlpar hyphpar 0 :10-pt :no-language)
(:grammar-num 8)
(:grammar s :grammar-num nowidctlpar :asian-keywords hyphpar 0 :10-pt :english)
((+ :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)
(:grammar-header-num 9)
(:grammar-header s :grammar-header-num sb 60 sa 180 keep keepn nowidctlpar :asian-keywords 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)
(:grammar-lhs-num 10)
(:grammar-lhs s :grammar-lhs-num fi -1440 li 1800 keep keepn nowidctlpar :asian-keywords hyphpar 0 :10-pt :english)
((+ :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)
(:grammar-lhs-last-num 11)
(:grammar-lhs-last s :grammar-lhs-last-num fi -1440 li 1800 sa 180 keep nowidctlpar :asian-keywords hyphpar 0 :10-pt :english)
((+ :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)
(:grammar-rhs-num 12)
(:grammar-rhs s :grammar-rhs-num fi -1260 li 1800 keep keepn nowidctlpar :asian-keywords tx 720 hyphpar 0 :10-pt :english)
((+ :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)
(:grammar-rhs-last-num 13)
(:grammar-rhs-last s :grammar-rhs-last-num fi -1260 li 1800 sa 180 keep nowidctlpar :asian-keywords tx 720 hyphpar 0 :10-pt :english)
((+ :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)
(:grammar-argument-num 14)
(:grammar-argument s :grammar-argument-num fi -1440 li 1800 sa 180 keep nowidctlpar :asian-keywords hyphpar 0 :10-pt :english)
((+ :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;"))
(:algorithm-simple-num 15)
(:algorithm-simple s :algorithm-simple-num li 480 sa 180 keep widctlpar :asian-keywords hyphpar 0 :10-pt :english)
((+ :styles) (:algorithm-simple sbasedon :body-text-num snext :algorithm-simple-num "Algorithm Simple;"))
(: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;"))
(:algorithm-0-num 16)
(:algorithm-0 s :algorithm-0-num fi -480 li 720 keep keepn nowidctlpar :asian-keywords hyphpar 0 :10-pt :english)
((+ :styles) (:algorithm-0 sbasedon :normal-num snext :algorithm-0-num "Algorithm 0;"))
(: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;"))
(:algorithm-0-narrow-num 17)
(:algorithm-0-narrow s :algorithm-0-narrow-num fi -480 li 720 sa 40 keep nowidctlpar :asian-keywords hyphpar 0 :10-pt :english)
((+ :styles) (:algorithm-0-narrow sbasedon :algorithm-0-num snext :body-text-num "Algorithm 0 Narrow;"))
(:algorithm-stmt-narrow :algorithm-0-narrow)
(:algorithm-0-last-num 18)
(:algorithm-0-last s :algorithm-0-last-num fi -480 li 720 sa 180 keep nowidctlpar :asian-keywords hyphpar 0 :10-pt :english)
((+ :styles) (:algorithm-0-last sbasedon :algorithm-0-num snext :body-text-num "Algorithm 0 Last;"))
(:algorithm-stmt :algorithm-0-last)
(:algorithm-1-num 19)
(:algorithm-1 s :algorithm-1-num fi -480 li 960 keep keepn nowidctlpar :asian-keywords hyphpar 0 :10-pt :english)
((+ :styles) (:algorithm-1 sbasedon :algorithm-0-num snext :algorithm-1-num "Algorithm 1;"))
(:algorithm-1-last-num 20)
(:algorithm-1-last s :algorithm-1-last-num fi -480 li 960 sa 180 keep nowidctlpar :asian-keywords hyphpar 0 :10-pt :english)
((+ :styles) (:algorithm-1-last sbasedon :algorithm-1-num snext :body-text-num "Algorithm 1 Last;"))
(:algorithm-next-stmt :algorithm-1-last)
(:algorithm-2-num 21)
(:algorithm-2 s :algorithm-2-num fi -480 li 1200 keep keepn nowidctlpar :asian-keywords hyphpar 0 :10-pt :english)
((+ :styles) (:algorithm-2 sbasedon :algorithm-1-num snext :algorithm-2-num "Algorithm 2;"))
(:algorithm-2-last-num 22)
(:algorithm-2-last s :algorithm-2-last-num fi -480 li 1200 sa 180 keep nowidctlpar :asian-keywords hyphpar 0 :10-pt :english)
((+ :styles) (:algorithm-2-last sbasedon :algorithm-2-num snext :body-text-num "Algorithm 2 Last;"))
(:algorithm-3-num 23)
(:algorithm-3 s :algorithm-3-num fi -480 li 1440 keep keepn nowidctlpar :asian-keywords hyphpar 0 :10-pt :english)
((+ :styles) (:algorithm-3 sbasedon :algorithm-2-num snext :algorithm-3-num "Algorithm 3;"))
(:algorithm-4-num 24)
(:algorithm-4 s :algorithm-4-num fi -480 li 1680 keep keepn nowidctlpar :asian-keywords hyphpar 0 :10-pt :english)
((+ :styles) (:algorithm-4 sbasedon :algorithm-3-num snext :algorithm-4-num "Algorithm 4;"))
(:algorithm-5-num 25)
(:algorithm-5 s :algorithm-5-num fi -480 li 1920 keep keepn nowidctlpar :asian-keywords hyphpar 0 :10-pt :english)
((+ :styles) (:algorithm-5 sbasedon :algorithm-4-num snext :algorithm-5-num "Algorithm 5;"))
(:algorithm-6-num 26)
(:algorithm-6 s :algorithm-6-num fi -480 li 2160 keep keepn nowidctlpar :asian-keywords hyphpar 0 :10-pt :english)
((+ :styles) (:algorithm-6 sbasedon :algorithm-5-num snext :algorithm-6-num "Algorithm 6;"))
(:algorithm-7-num 27)
(:algorithm-7 s :algorithm-7-num fi -480 li 2400 keep keepn nowidctlpar :asian-keywords hyphpar 0 :10-pt :english)
((+ :styles) (:algorithm-7 sbasedon :algorithm-6-num snext :algorithm-7-num "Algorithm 7;"))
(:algorithm-8-num 28)
(:algorithm-8 s :algorithm-8-num fi -480 li 2640 keep keepn nowidctlpar :asian-keywords hyphpar 0 :10-pt :english)
((+ :styles) (:algorithm-8 sbasedon :algorithm-7-num snext :algorithm-8-num "Algorithm 8;"))
(:algorithm-9-num 29)
(:algorithm-9 s :algorithm-9-num fi -480 li 2880 keep keepn nowidctlpar :asian-keywords hyphpar 0 :10-pt :english)
((+ :styles) (:algorithm-9 sbasedon :algorithm-8-num snext :algorithm-9-num "Algorithm 9;"))
(:default-paragraph-font-num 30)
(:default-paragraph-font cs :default-paragraph-font-num)
@ -592,7 +315,7 @@
((+ :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 :navy)
(:character-literal-control cs :character-literal-control-num b 0 :times :navy :no-language)
((+ :styles) (* :character-literal-control additive sbasedon :default-paragraph-font-num "Character Literal Control;"))
(:terminal-num 34)
@ -608,11 +331,11 @@
((+ :styles) (* :nonterminal additive sbasedon :default-paragraph-font-num "Nonterminal;"))
(:nonterminal-attribute-num 37)
(:nonterminal-attribute cs :nonterminal-attribute-num i 0)
(:nonterminal-attribute cs :nonterminal-attribute-num i 0 :no-language)
((+ :styles) (* :nonterminal-attribute additive sbasedon :default-paragraph-font-num "Nonterminal Attribute;"))
(:nonterminal-argument-num 38)
(:nonterminal-argument cs :nonterminal-argument-num)
(:nonterminal-argument cs :nonterminal-argument-num :no-language)
((+ :styles) (* :nonterminal-argument additive sbasedon :default-paragraph-font-num "Nonterminal Argument;"))
(:semantic-keyword-num 40)
@ -644,44 +367,51 @@
(:action-name cs :action-name-num :zapf-chancery :purple :no-language)
((+ :styles) (* :action-name additive sbasedon :default-paragraph-font-num "Action Name;"))
#|
(:id-name-num 47)
(:id-name cs :id-name-num scaps :helvetica :no-language)
((+ :styles) (* :id-name additive sbasedon :default-paragraph-font-num "Id Name;"))
|#
(:heading1-num 61)
(:heading1 s :heading1-num qj fi -720 li 720 sb 240 sa 180 keep keepn widctlpar hyphpar 0 level 1 b :14-pt :english)
(:heading1 s :heading1-num qj fi -720 li 720 sb 240 sa 180 keep keepn widctlpar :asian-keywords hyphpar 0 level 1 b :14-pt :english)
((+ :styles) (:heading1 sbasedon :normal-num snext :body-text-num "heading 1;"))
(:heading2-num 62)
(:heading2 s :heading2-num qj fi -720 li 720 sb 240 sa 120 keep keepn widctlpar hyphpar 0 level 2 b :12-pt :english)
(:heading2 s :heading2-num qj fi -720 li 720 sb 120 sa 180 keep keepn widctlpar :asian-keywords hyphpar 0 level 2 b :12-pt :english)
((+ :styles) (:heading2 sbasedon :heading1-num snext :body-text-num "heading 2;"))
(:heading3-num 63)
(:heading3 s :heading3-num qj fi -720 li 720 sb 180 sa 90 keep keepn widctlpar hyphpar 0 level 3 b :10-pt :english)
(:heading3 s :heading3-num qj fi -720 li 720 sb 60 sa 120 keep keepn widctlpar :asian-keywords hyphpar 0 level 3 b :10-pt :english)
((+ :styles) (:heading3 sbasedon :heading2-num snext :body-text-num "heading 3;"))
(:section-heading :heading3)
(:heading4-num 64)
(:heading4 s :heading4-num qj fi -720 li 720 sb 120 sa 60 keep keepn widctlpar hyphpar 0 level 4 b :10-pt :english)
(:heading4 s :heading4-num qj fi -720 li 720 sa 120 keep keepn widctlpar :asian-keywords hyphpar 0 level 4 b :10-pt :english)
((+ :styles) (:heading4 sbasedon :heading3-num snext :body-text-num "heading 4;"))
(:subsection-heading :heading4)
(:sample-code-num 70)
(:sample-code s :sample-code-num li 1440 sb 60 sa 60 keep nowidctlpar hyphpar 0 b :courier :blue :10-pt :no-language)
(:sample-code s :sample-code-num li 1440 sa 180 keep nowidctlpar :asian-keywords hyphpar 0 b :courier :blue :10-pt :no-language)
((+ :styles) (:sample-code sbasedon :normal-num snext :body-text-num "Sample Code;"))
;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")))))
(:page-number-field (field (* fldinst (:page-number " PAGE ")) (fldrslt (:page-number :no-language "1"))))
(:left-header-group headerl :reset-paragraph :header)
(:right-header-group headerr :reset-paragraph :header)
;(:left-footer-group (footerl :reset-paragraph :footer tab :page-number-field))
;(:right-footer-group (footerr :reset-paragraph :footer tab :page-number-field))
;Document Formatting
(:docfmt widowctrl
(:docfmt margl 720
margr 720
margb 720
gutter 720
facingp ;mirror left/right gutters
widowctrl
ftnbj ;footnotes at bottom of page
aenddoc ;endnotes at end of document
noxlattoyen ;don't translate backslash to yen
hyphcaps 0 ;don't hyphenate capitalized words
fet 0 ;footnotes only -- no endnotes
formshade ;shade form fields
viewkind 4 ;normal view mode
@ -694,11 +424,85 @@
;Specials
(:mod-date s :normal-num qr sa 120 widctlpar :10-pt :english i)
(:plain-subscript b 0 i 0 sub)
(: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)
(:plain-subscript b 0 i 0 :subscript)
(:superscript super)
((:action-begin 1) "[")
((:action-end 1) "]")
((: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))
((:record-begin 1) (b :left-triangle-bracket-10 :left-triangle-bracket-10))
((:record-end 1) (b :right-triangle-bracket-10 :right-triangle-bracket-10))
((:true 4) (:global-variable "true"))
((:false 5) (:global-variable "false"))
((:unique 6) (:semantic-keyword "unique"))
(:mod-date s :normal-num qr sa 120 widctlpar :asian-keywords :10-pt :english i)
))
(defparameter *division-widths*
'((:nowrap . 0)
(:level . 4)
(:algorithm . 0)
(:algorithm-next . 4)
(:grammar-rule . 0)
(:js2 . 0)
(:es4 . 0)))
(defparameter *division-style-specializations*
'((:nowrap . t)
(:level (:statement . :statement-1)
(:statement-1 . :statement-2)
(:statement-2 . :statement-3)
(:statement-3 . :statement-4)
(:statement-4 . :statement-5)
(:statement-5 . :statement-6)
(:statement-6 . :statement-7)
(:statement-7 . :statement-8)
(:statement-8 . :statement-9)
(:statement-last . :statement-1-last))
(:algorithm (:statement . :algorithm-0)
(:statement-1 . :algorithm-1)
(:statement-2 . :algorithm-2)
(:statement-3 . :algorithm-3)
(:statement-4 . :algorithm-4)
(:statement-5 . :algorithm-5)
(:statement-6 . :algorithm-6)
(:statement-7 . :algorithm-7)
(:statement-8 . :algorithm-8)
(:statement-9 . :algorithm-9)
(:statement-last . :algorithm-0-last)
(:statement-1-last . :algorithm-1-last))
(:algorithm-next (:statement . :algorithm-1)
(:statement-1 . :algorithm-2)
(:statement-2 . :algorithm-3)
(:statement-3 . :algorithm-4)
(:statement-4 . :algorithm-5)
(:statement-5 . :algorithm-6)
(:statement-6 . :algorithm-7)
(:statement-7 . :algorithm-8)
(:statement-8 . :algorithm-9)
(:statement-last . :algorithm-1-last)
(:statement-1-last . :algorithm-2-last))
(:grammar-rule . t)
(:js2 . t)
(:es4 . t)))
;;; ------------------------------------------------------------------------------------------------------
;;; SIMPLE LINE BREAKER
@ -1011,10 +815,11 @@
;;; RTF STREAMS
(defstruct (rtf-stream (:include markup-stream)
(:constructor allocate-rtf-stream (env head tail level logical-position))
(:constructor allocate-rtf-stream (env head tail level logical-line-width logical-position enclosing-styles))
(:copier nil)
(:predicate rtf-stream?))
(style nil :type symbol)) ;Current section or paragraph style or nil if none or emitting paragraph contents
(enclosing-styles nil :type list) ;A list of enclosing division styles
(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)
@ -1023,9 +828,9 @@
; 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)
(defun make-rtf-stream (markup-env level logical-line-width logical-position enclosing-styles)
(let ((head (list nil)))
(allocate-rtf-stream markup-env head head level logical-position)))
(allocate-rtf-stream markup-env head head level logical-line-width logical-position enclosing-styles)))
; Make a new, empty, open, top-level rtf-stream with the given definitions
@ -1034,7 +839,7 @@
(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)))
(allocate-rtf-stream markup-env head head *markup-stream-top-level* *markup-logical-line-width* nil nil)))
; Append a block to the end of the rtf-stream. The block may be inlined
@ -1072,19 +877,12 @@
(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)))
(defun generate-left-header-group (title time)
(list :left-header-group :page-number-field 'tab (assert-type title string) " " (time-to-short-string time)))
(defun generate-right-header-group (title time)
(list :right-header-group (assert-type title string) " " (time-to-short-string time) 'tab :page-number-field))
; Create a top-level rtf-stream and call emitter to emit its contents.
@ -1092,7 +890,11 @@
; Return the top-level rtf-stream.
(defun depict-rtf-top-level (title emitter &optional (rtf-definitions *rtf-definitions*))
(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*))
(rtf-stream (make-rtf-stream (markup-stream-env top-rtf-stream)
*markup-stream-paragraph-level*
*markup-logical-line-width*
nil
nil))
(time (get-universal-time)))
(markup-stream-append1 rtf-stream :rtf-intro)
(let ((info (generate-document-info title *rtf-author* *rtf-company* time)))
@ -1100,8 +902,10 @@
(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)
(markup-stream-append1 rtf-stream (generate-left-header-group title time))
(markup-stream-append1 rtf-stream (generate-right-header-group title time))
;(markup-stream-append1 rtf-stream :left-footer-group)
;(markup-stream-append1 rtf-stream :right-footer-group)
(funcall emitter rtf-stream)
(markup-stream-append1 top-rtf-stream (markup-stream-unexpanded-output rtf-stream))
top-rtf-stream))
@ -1117,39 +921,178 @@
filename)
(defun debug-depict-rtf (title emitter &optional (rtf-definitions *rtf-definitions*))
(let ((top-rtf-stream (depict-rtf-top-level title emitter rtf-definitions)))
(markup-stream-output top-rtf-stream)))
; 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))
; Return a freshly consed list of rtf-items that represent the characters in the string except that
; spaces are replaced by nonbreakable spaces.
(defun convert-rtf-string-spaces-to-nbsps (string)
(let ((rtf-items nil))
(labels
((escape-remainder (start)
(let ((i (position #\space string :start start)))
(if i
(progn
(unless (= i start)
(push (subseq string start i) rtf-items))
(push '~ rtf-items)
(escape-remainder (1+ i)))
(push (if (zerop start) string (subseq string start)) rtf-items)))))
(escape-remainder 0)
(nreverse rtf-items))))
; Destructively convert spaces inside strings in rtf-item into nonbreakable spaces.
; Return a freshly consed list of the results.
(defun convert-rtf-item-spaces-to-nbsps (rtf-item)
(cond
((stringp rtf-item)
(convert-rtf-string-spaces-to-nbsps rtf-item))
((or (characterp rtf-item) (symbolp rtf-item) (integerp rtf-item))
(list rtf-item))
((consp rtf-item)
(list (convert-rtf-list-spaces-to-nbsps rtf-item)))
(t (error "Bad rtf-item: ~S" rtf-item))))
; Destructively convert spaces inside strings in rtf-list into nonbreakable spaces.
(defun convert-rtf-list-spaces-to-nbsps (rtf-list)
(mapcan #'convert-rtf-item-spaces-to-nbsps rtf-list))
(defun depict-nowrap-rtf-style (rtf-stream emitter)
(let ((saved-tail (rtf-stream-tail rtf-stream)))
(setf (rtf-stream-pretail rtf-stream) nil)
(prog1
(funcall emitter rtf-stream)
(setf (cdr saved-tail) (convert-rtf-list-spaces-to-nbsps (cdr saved-tail)))
(setf (rtf-stream-tail rtf-stream) (last saved-tail))
(setf (rtf-stream-pretail rtf-stream) nil))))
(defmethod depict-division-style-f ((rtf-stream rtf-stream) division-style flatten emitter)
(assert-true (= (markup-stream-level rtf-stream) *markup-stream-paragraph-level*))
(funcall emitter rtf-stream))
(assert-true (symbolp division-style))
(if (or (null division-style)
(and flatten (member division-style (rtf-stream-enclosing-styles rtf-stream))))
(funcall emitter rtf-stream)
(let ((width (cdr (assert-non-null (assoc division-style *division-widths*)))))
(decf (rtf-stream-logical-line-width rtf-stream) width)
(push division-style (rtf-stream-enclosing-styles rtf-stream))
(prog1
(if (eq division-style :nowrap)
(depict-nowrap-rtf-style rtf-stream emitter)
(funcall emitter rtf-stream))
(pop (rtf-stream-enclosing-styles rtf-stream))
(incf (rtf-stream-logical-line-width rtf-stream) width)))))
(defun specialize-paragraph-style (rtf-stream paragraph-style)
(dolist (enclosing-style (rtf-stream-enclosing-styles rtf-stream))
(let ((map (assoc enclosing-style *division-style-specializations*)))
(unless map
(error "Cannot specialize division style ~S" enclosing-style))
(setq map (cdr map))
(unless (eq map t)
(let ((new-style (assoc paragraph-style map)))
(unless new-style
(error "Cannot specialize division style ~S containing a ~S paragraph" enclosing-style paragraph-style))
(setq paragraph-style (cdr new-style))))))
paragraph-style)
; rtf is the output from a rtf-stream consisting of paragraphs.
; Return rtf flattened to a single paragraph with the given paragraph-style with spaces inserted
; between the component paragraphs. saved-style is the style inherited at the beginning of the rtf.
; May destroy the original rtf list.
(defun flatten-rtf-paragraphs (rtf paragraph-style saved-style)
(assert-true rtf)
(let* ((delete-next nil)
(flattened-rtf (mapcan #'(lambda (item)
(cond
(delete-next
(setq delete-next nil)
nil)
((eq item :new-paragraph) (list " "))
((eq item :reset-paragraph)
(setq delete-next t)
nil)
(t (list item))))
rtf)))
(assert-true (not delete-next))
(unless (eq paragraph-style saved-style)
(setq flattened-rtf (list* :reset-paragraph paragraph-style flattened-rtf)))
(let ((last (last flattened-rtf)))
(assert-true (string= (car last) " "))
(setf (car last) :new-paragraph))
flattened-rtf))
(defmethod depict-division-block-f ((rtf-stream rtf-stream) paragraph-style paragraph-styles division-styles emitter)
(declare (ignore paragraph-styles division-styles))
(assert-true (= (markup-stream-level rtf-stream) *markup-stream-paragraph-level*))
(assert-true (and paragraph-style (symbolp paragraph-style)))
(let ((paragraph-style (specialize-paragraph-style rtf-stream paragraph-style))
(logical-line-width (rtf-stream-logical-line-width rtf-stream))
(saved-division-length (rtf-stream-division-length rtf-stream))
(saved-style (rtf-stream-style rtf-stream))
(saved-tail (rtf-stream-tail rtf-stream)))
(setf (rtf-stream-division-length rtf-stream) 0)
(setf (rtf-stream-pretail rtf-stream) nil)
(prog1
(funcall emitter rtf-stream)
(let ((inner-length (rtf-stream-division-length rtf-stream)))
(unless (eq inner-length t)
(if (> inner-length logical-line-width)
(setq inner-length t)
(let ((flattened (flatten-rtf-paragraphs (cdr saved-tail) paragraph-style saved-style)))
(setf (cdr saved-tail) flattened)
(setf (rtf-stream-tail rtf-stream) (last saved-tail))
(setf (rtf-stream-pretail rtf-stream) nil))))
(setf (rtf-stream-division-length rtf-stream) saved-division-length)
(increment-division-length rtf-stream inner-length)))))
(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)))
(let ((paragraph-style (specialize-paragraph-style rtf-stream paragraph-style)))
(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) paragraph-style))
(let ((logical-position (make-logical-position)))
(setf (rtf-stream-level rtf-stream) *markup-stream-content-level*)
(setf (rtf-stream-logical-position rtf-stream) logical-position)
(prog1
(funcall emitter rtf-stream)
(assert-true (and (eq logical-position (rtf-stream-logical-position rtf-stream))
(null (logical-position-n-soft-breaks logical-position))))
(increment-division-length rtf-stream (if (= (logical-position-n-hard-breaks logical-position) 0)
(1+ (logical-position-position logical-position))
t))
(setf (rtf-stream-level rtf-stream) *markup-stream-paragraph-level*)
(setf (rtf-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*))
(if char-style
(let ((inner-rtf-stream (make-rtf-stream (markup-stream-env rtf-stream) *markup-stream-content-level* (markup-stream-logical-position rtf-stream))))
(let ((inner-rtf-stream (make-rtf-stream (rtf-stream-env rtf-stream)
*markup-stream-content-level*
(rtf-stream-logical-line-width rtf-stream)
(rtf-stream-logical-position rtf-stream)
(rtf-stream-enclosing-styles rtf-stream))))
(assert-true (symbolp char-style))
(markup-stream-append1 inner-rtf-stream char-style)
(prog1
@ -1162,12 +1105,12 @@
(declare (ignore style)))
(defmethod save-block-style ((rtf-stream rtf-stream))
(defmethod save-division-style ((rtf-stream rtf-stream))
nil)
(defmethod with-saved-block-style-f ((rtf-stream rtf-stream) saved-block-style flatten emitter)
(declare (ignore saved-block-style flatten))
(defmethod with-saved-division-style-f ((rtf-stream rtf-stream) saved-division-style flatten emitter)
(declare (ignore saved-division-style flatten))
(assert-true (= (markup-stream-level rtf-stream) *markup-stream-paragraph-level*))
(funcall emitter rtf-stream))
@ -1319,7 +1262,7 @@
#|
(declaim (optimize (debug 1))) ;*****
(setq r (read-rtf-from-local-file ":private:Edition4a.rtf"))
(setq r (read-rtf-from-local-file "Huit:E4:E4.rtf"))
(delete-unused-rtf-list-overrides r)
(delete-unused-rtf-lists r)
(delete-datafields r)
@ -1332,4 +1275,9 @@
(each-rtf-tag r 'listid #'(lambda (rtf)
(assert-true (integerp (second rtf)))
(print (list (first rtf) (second rtf)))))
(debug-depict-rtf
"JavaScript 2 Lexical Grammar"
#'(lambda (rtf-stream)
(depict-world-commands rtf-stream *lw* :visible-semantics nil)))
|#

13
js2/semantics/styles.css
Просмотреть файл

@ -31,10 +31,15 @@ DT {font-style: italic; margin-top: 3pt}
.grammar-lhs {}
.grammar-rhs {margin-left: 9pt;}
.grammar-argument {margin-left: 18pt; margin-top: 6pt; margin-bottom: 6pt}
.semantics {margin-left: 9pt; margin-top: 3pt; margin-bottom: 3pt}
.semantics-next {margin-left: 27pt; margin-bottom: 3pt}
.semantic-comment {margin-left: 9pt; margin-top: 9pt; margin-bottom: 0pt}
.algorithm {margin-left: 9pt; margin-top: 6pt; margin-bottom: 6pt}
.algorithm-next {margin-left: 27pt; margin-bottom: 6pt}
.stmt {margin-left: 36pt; text-indent: -36pt}
.lvl {margin-left: 18pt}
.algorithm-stmt {margin-left: 45pt; text-indent: -36pt; margin-top: 6pt; margin-bottom: 6pt}
.algorithm-next-stmt {margin-left: 63pt; text-indent: -36pt; margin-bottom: 6pt}
.symbol {font-family: Symbol}
.unicode {font-family: "Lucida Sans Unicode", serif}
VAR, VAR A:link, VAR A:visited {font-family: Georgia, Palatino, "Times New Roman", Times, serif; font-weight: normal; font-style: italic; color: #336600}
@ -72,3 +77,7 @@ A.global-variable:active, A:active .global-variable {color: #00FF00}
.action-name, A.action-name:link, A.action-name:visited {font-family: "Zapf Chancery", "Comic Sans MS", Script, serif; color: #660066}
A.action-name:hover, A:hover .action-name {color: #663366}
A.action-name:active, A:active .action-name {color: #FF00FF}
/* Obsolete styles */
.semantics {margin-left: 9pt; margin-top: 3pt; margin-bottom: 3pt}
.semantics-next {margin-left: 27pt; margin-bottom: 3pt}