зеркало из https://github.com/mozilla/pjs.git
First Checked In.
This commit is contained in:
waldemar%netscape.com
Родитель
934f546c14
Коммит
0def3457bd
Разница между файлами не показана из-за своего большого размера
Загрузить разницу
|
|
@ -0,0 +1,998 @@
|
|||
;;; The contents of this file are subject to the Netscape Public License
|
||||
;;; Version 1.0 (the "NPL"); you may not use this file except in
|
||||
;;; compliance with the NPL. You may obtain a copy of the NPL at
|
||||
;;; http://www.mozilla.org/NPL/
|
||||
;;;
|
||||
;;; Software distributed under the NPL is distributed on an "AS IS" basis,
|
||||
;;; WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
|
||||
;;; for the specific language governing rights and limitations under the
|
||||
;;; NPL.
|
||||
;;;
|
||||
;;; The Initial Developer of this code under the NPL is Netscape
|
||||
;;; Communications Corporation. Portions created by Netscape are
|
||||
;;; Copyright (C) 1998 Netscape Communications Corporation. All Rights
|
||||
;;; Reserved.
|
||||
|
||||
;;;
|
||||
;;; ECMAScript semantic calculus markup emitters
|
||||
;;;
|
||||
;;; Waldemar Horwat (waldemar@netscape.com)
|
||||
;;;
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; SEMANTIC DEPICTION UTILITIES
|
||||
|
||||
(defparameter *semantic-keywords*
|
||||
'(not and or is type oneof tuple action lambda if then else in new case of end let letexc))
|
||||
|
||||
; Emit markup for one of the semantic keywords, as specified by keyword-symbol.
|
||||
(defun depict-semantic-keyword (markup-stream keyword-symbol)
|
||||
(assert-true (find keyword-symbol *semantic-keywords* :test #'eq))
|
||||
(depict-char-style (markup-stream :semantic-keyword)
|
||||
(depict markup-stream (string-downcase (symbol-name keyword-symbol)))))
|
||||
|
||||
|
||||
; If test is true, depict an opening parenthesis, evaluate body, and depict a closing
|
||||
; parentheses. Otherwise, just evaluate body.
|
||||
; Return the result value of body.
|
||||
(defmacro depict-optional-parentheses ((markup-stream test) &body body)
|
||||
(let ((temp (gensym "PAREN")))
|
||||
`(let ((,temp ,test))
|
||||
(when ,temp
|
||||
(depict ,markup-stream "("))
|
||||
(prog1
|
||||
(progn ,@body)
|
||||
(when ,temp
|
||||
(depict ,markup-stream ")"))))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; DEPICT-ENV
|
||||
|
||||
; A depict-env holds state that helps in depicting a grammar or lexer.
|
||||
(defstruct depict-env
|
||||
(grammar-info nil :type (or null grammar-info)) ;The current grammar-info or nil if none
|
||||
(seen-nonterminals nil :type (or null hash-table)) ;Hash table (nonterminal -> t) of nonterminals already depicted
|
||||
(mode nil :type (member nil :syntax :semantics)) ;Current heading (:syntax or :semantics) or nil if none
|
||||
(pending-actions-reverse nil :type list)) ;Reverse-order list of closures of actions pending for a %print-actions
|
||||
|
||||
|
||||
(defun checked-depict-env-grammar-info (depict-env)
|
||||
(or (depict-env-grammar-info depict-env)
|
||||
(error "Grammar needed")))
|
||||
|
||||
|
||||
(defvar *visible-modes* t)
|
||||
|
||||
; Set the mode to the given mode, emitting a heading if necessary.
|
||||
(defun depict-mode (markup-stream depict-env mode)
|
||||
(unless (eq mode (depict-env-mode depict-env))
|
||||
(when *visible-modes*
|
||||
(ecase mode
|
||||
(:syntax (depict-paragraph (markup-stream ':grammar-header)
|
||||
(depict markup-stream "Syntax")))
|
||||
(:semantics (depict-paragraph (markup-stream ':grammar-header)
|
||||
(depict markup-stream "Semantics")))
|
||||
((nil))))
|
||||
(setf (depict-env-mode depict-env) mode)))
|
||||
|
||||
|
||||
; Emit markup paragraphs for a command.
|
||||
(defun depict-command (markup-stream world depict-env command)
|
||||
(handler-bind ((error #'(lambda (condition)
|
||||
(declare (ignore condition))
|
||||
(format *error-output* "~&While depicting: ~:W~%" command))))
|
||||
(let ((depictor (and (consp command)
|
||||
(identifier? (first command))
|
||||
(get (world-intern world (first command)) :depict-command))))
|
||||
(if depictor
|
||||
(apply depictor markup-stream world depict-env (rest command))
|
||||
(error "Bad command: ~S" command)))))
|
||||
|
||||
|
||||
; Emit markup paragraphs for the world's commands.
|
||||
(defun depict-world-commands (markup-stream world)
|
||||
(let ((depict-env (make-depict-env)))
|
||||
(dolist (command (world-commands-source world))
|
||||
(depict-command markup-stream world depict-env command))
|
||||
(depict-clear-grammar markup-stream world depict-env)))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; DEPICTING TYPES
|
||||
|
||||
(defconstant *type-level-min* 0)
|
||||
(defconstant *type-level-suffix* 1)
|
||||
(defconstant *type-level-function* 2)
|
||||
(defconstant *type-level-max* 2)
|
||||
;;;
|
||||
;;; The level argument indicates what kinds of component types may be represented without being placed
|
||||
;;; in parentheses.
|
||||
;;; level kinds
|
||||
;;; 0 id, oneof, tuple, (type)
|
||||
;;; 1 id, oneof, tuple, (type), type[], type^
|
||||
;;; 2 id, oneof, tuple, (type), type[], type^, type x type -> type
|
||||
|
||||
|
||||
; Emit markup for the name of a type, which must be a symbol.
|
||||
(defun depict-type-name (markup-stream type-name)
|
||||
(depict-char-style (markup-stream :type-name)
|
||||
(depict markup-stream (symbol-upper-mixed-case-name type-name))))
|
||||
|
||||
|
||||
; Emit markup for the name of a tuple or oneof field, which must be a symbol.
|
||||
(defun depict-field-name (markup-stream field-name)
|
||||
(depict-char-style (markup-stream :field-name)
|
||||
(depict markup-stream (symbol-lower-mixed-case-name field-name))))
|
||||
|
||||
|
||||
; If level < threshold, depict an opening parenthesis, evaluate body, and depict a closing
|
||||
; parentheses. Otherwise, just evaluate body.
|
||||
; Return the result value of body.
|
||||
(defmacro depict-type-parentheses ((markup-stream level threshold) &body body)
|
||||
`(depict-optional-parentheses (,markup-stream (< ,level ,threshold))
|
||||
,@body))
|
||||
|
||||
|
||||
; Emit markup for the given type expression. level is non-nil if this is a recursive
|
||||
; call to depict-type-expr for which the markup-stream's style is :type-expression.
|
||||
; In this case level indicates the binding level imposed by the enclosing type expression.
|
||||
(defun depict-type-expr (markup-stream world type-expr &optional level)
|
||||
(cond
|
||||
((identifier? type-expr)
|
||||
(depict-type-name markup-stream type-expr))
|
||||
((type? type-expr)
|
||||
(let ((type-str (print-type-to-string type-expr)))
|
||||
(warn "Depicting raw type ~A" type-str)
|
||||
(depict markup-stream "<<<" type-str ">>>")))
|
||||
(t (let ((depictor (get (world-intern world (first type-expr)) :depict-type-constructor)))
|
||||
(if level
|
||||
(apply depictor markup-stream world level (rest type-expr))
|
||||
(depict-char-style (markup-stream :type-expression)
|
||||
(apply depictor markup-stream world *type-level-max* (rest type-expr))))))))
|
||||
|
||||
|
||||
; (-> (<arg-type1> ... <arg-typen>) <result-type>)
|
||||
; Level 2
|
||||
; "<arg-type1>@1 x ... x <arg-typen>@1 -> <result-type>@1"
|
||||
(defun depict--> (markup-stream world level arg-type-exprs result-type-expr)
|
||||
(depict-type-parentheses (markup-stream level *type-level-function*)
|
||||
(depict-list markup-stream
|
||||
#'(lambda (markup-stream arg-type-expr)
|
||||
(depict-type-expr markup-stream world arg-type-expr *type-level-suffix*))
|
||||
arg-type-exprs
|
||||
:separator '(" " :cartesian-product-10 " ")
|
||||
:empty "()")
|
||||
(depict markup-stream " " :function-arrow-10 " ")
|
||||
(depict-type-expr markup-stream world result-type-expr *type-level-suffix*)))
|
||||
|
||||
|
||||
; (vector <element-type>)
|
||||
; Level 1
|
||||
; "<element-type>@1[]"
|
||||
(defun depict-vector (markup-stream world level element-type-expr)
|
||||
(depict-type-parentheses (markup-stream level *type-level-suffix*)
|
||||
(depict-type-expr markup-stream world element-type-expr *type-level-suffix*)
|
||||
(depict markup-stream "[]")))
|
||||
|
||||
|
||||
; (address <element-type>)
|
||||
; Level 1
|
||||
; "<element-type>@1^"
|
||||
(defun depict-address (markup-stream world level element-type-expr)
|
||||
(depict-type-parentheses (markup-stream level *type-level-suffix*)
|
||||
(depict-type-expr markup-stream world element-type-expr *type-level-suffix*)
|
||||
(depict markup-stream :up-arrow-10)))
|
||||
|
||||
|
||||
(defun depict-tuple-or-oneof (markup-stream world keyword-symbol tag-pairs)
|
||||
(depict-semantic-keyword markup-stream keyword-symbol)
|
||||
(depict-list
|
||||
markup-stream
|
||||
#'(lambda (markup-stream tag-pair)
|
||||
(if (identifier? tag-pair)
|
||||
(depict-field-name markup-stream tag-pair)
|
||||
(progn
|
||||
(depict-field-name markup-stream (first tag-pair))
|
||||
(depict markup-stream ": ")
|
||||
(depict-type-expr markup-stream world (second tag-pair) *type-level-function*))))
|
||||
tag-pairs
|
||||
:indent 6
|
||||
:prefix " {"
|
||||
:prefix-break 0
|
||||
:suffix "}"
|
||||
:separator ";"
|
||||
:break 1
|
||||
:empty nil))
|
||||
|
||||
; (oneof (<tag1> <type1>) ... (<tagn> <typen>))
|
||||
; Level 0
|
||||
; "ONEOF{<tag1>: <type1>@0; ...; <tagn>:<typen>@0}"
|
||||
(defun depict-oneof (markup-stream world level &rest tags-and-types)
|
||||
(declare (ignore level))
|
||||
(depict-tuple-or-oneof markup-stream world 'oneof tags-and-types))
|
||||
|
||||
; (tuple (<tag1> <type1>) ... (<tagn> <typen>))
|
||||
; Level 0
|
||||
; "TUPLE{<tag1>: <type1>@0; ...; <tagn>:<typen>@0}"
|
||||
(defun depict-tuple (markup-stream world level &rest tags-and-types)
|
||||
(declare (ignore level))
|
||||
(depict-tuple-or-oneof markup-stream world 'tuple tags-and-types))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; DEPICTING EXPRESSIONS
|
||||
|
||||
|
||||
(defconstant *primitive-level-min* 0)
|
||||
(defconstant *primitive-level-unary-suffix* 1)
|
||||
(defconstant *primitive-level-unary-prefix* 2)
|
||||
(defconstant *primitive-level-unary* 3)
|
||||
(defconstant *primitive-level-multiplicative* 4)
|
||||
(defconstant *primitive-level-additive* 5)
|
||||
(defconstant *primitive-level-relational* 6)
|
||||
(defconstant *primitive-level-logical* 7)
|
||||
(defconstant *primitive-level-unparenthesized-new* 8)
|
||||
(defconstant *primitive-level-expr* 9)
|
||||
(defconstant *primitive-level-stmt* 10)
|
||||
(defconstant *primitive-level-max* 10)
|
||||
;;;
|
||||
;;; The level argument indicates what kinds of subexpressions may be represented without being placed
|
||||
;;; in parentheses (or on a separate line for the case of lambda and if/then/else).
|
||||
;;; level kinds
|
||||
;;; 0 id, constant, (e)
|
||||
;;; 1 id, constant, (e), f(...), new(v), a[i]
|
||||
;;; 2 id, constant, (e), -e, @
|
||||
;;; 3 id, constant, (e), f(...), new(v), a[i], -e, @
|
||||
;;; 4 id, constant, (e), f(...), new(v), a[i], -e, @, /, *
|
||||
;;; 5 id, constant, (e), f(...), new(v), a[i], -e, @, /, *, +, -
|
||||
;;; 6 id, constant, (e), f(...), new(v), a[i], -e, @, /, *, +, -, relationals
|
||||
;;; 7 id, constant, (e), f(...), new(v), a[i], -e, @, /, *, +, -, relationals, logicals
|
||||
;;; 8 id, constant, (e), f(...), new(v), a[i], -e, @, /, *, +, -, relationals, logicals, new v
|
||||
;;; 9 id, constant, (e), f(...), new(v), a[i], -e, @, /, *, +, -, relationals, logicals, new v
|
||||
;;; 10 id, constant, (e), f(...), new(v), a[i], -e, @, /, *, +, -, relationals, logicals, new v, :=, lambda, if/then/else
|
||||
|
||||
; Return true if primitive-level1 is a superset of primitive-level2
|
||||
; in the partial order of primitive levels.
|
||||
(defun primitive-level->= (primitive-level1 primitive-level2)
|
||||
(and (>= primitive-level1 primitive-level2)
|
||||
(or (/= primitive-level1 *primitive-level-unary-prefix*)
|
||||
(/= primitive-level2 *primitive-level-unary-suffix*))))
|
||||
|
||||
|
||||
; If primitive-level is not a superset of threshold, depict an opening parenthesis,
|
||||
; evaluate body, and depict a closing parentheses. Otherwise, just evaluate body.
|
||||
; Return the result value of body.
|
||||
(defmacro depict-expr-parentheses ((markup-stream primitive-level threshold) &body body)
|
||||
`(depict-optional-parentheses (,markup-stream (not (primitive-level->= ,primitive-level ,threshold)))
|
||||
,@body))
|
||||
|
||||
|
||||
; Emit markup for the name of a global variable, which must be a symbol.
|
||||
(defun depict-global-variable (markup-stream name)
|
||||
(depict-char-style (markup-stream :global-variable)
|
||||
(depict markup-stream (symbol-lower-mixed-case-name name))))
|
||||
|
||||
|
||||
; Emit markup for the name of a local variable, which must be a symbol.
|
||||
(defun depict-local-variable (markup-stream name)
|
||||
(depict-char-style (markup-stream :local-variable)
|
||||
(depict markup-stream (symbol-lower-mixed-case-name name))))
|
||||
|
||||
|
||||
; Emit markup for the name of an action, which must be a symbol.
|
||||
(defun depict-action-name (markup-stream action-name)
|
||||
(depict-char-style (markup-stream :action-name)
|
||||
(depict markup-stream (symbol-upper-mixed-case-name action-name))))
|
||||
|
||||
|
||||
; Emit markup for the value constant.
|
||||
(defun depict-constant (markup-stream constant)
|
||||
(cond
|
||||
((integerp constant)
|
||||
(depict-integer markup-stream constant))
|
||||
((floatp constant)
|
||||
(depict markup-stream (format nil (if (= constant (floor constant 1)) "~,1F" "~F") constant)))
|
||||
((characterp constant)
|
||||
(depict markup-stream ':left-single-quote)
|
||||
(depict-char-style (markup-stream ':character-literal)
|
||||
(depict-character markup-stream constant nil))
|
||||
(depict markup-stream ':right-single-quote))
|
||||
((stringp constant)
|
||||
(depict-string markup-stream constant))
|
||||
(t (error "Bad constant ~S" constant))))
|
||||
|
||||
|
||||
; Emit markup for the primitive when it is not called in a function call.
|
||||
(defun depict-primitive (markup-stream primitive)
|
||||
(unless (eq (primitive-appearance primitive) ':global)
|
||||
(error "Can't depict primitive ~S outside a call" primitive))
|
||||
(depict-item-or-group-list markup-stream (primitive-markup1 primitive)))
|
||||
|
||||
|
||||
; Emit markup for the parameters to a function call.
|
||||
(defun depict-call-parameters (markup-stream world annotated-parameters)
|
||||
(depict-list markup-stream
|
||||
#'(lambda (markup-stream parameter)
|
||||
(depict-annotated-value-expr markup-stream world parameter))
|
||||
annotated-parameters
|
||||
:indent 4
|
||||
:prefix "("
|
||||
:prefix-break 0
|
||||
:suffix ")"
|
||||
:separator ","
|
||||
:break 1
|
||||
:empty nil))
|
||||
|
||||
|
||||
; Emit markup for the function or primitive call. level indicates the binding level imposed
|
||||
; by the enclosing expression.
|
||||
(defun depict-call (markup-stream world level annotated-function-expr &rest annotated-arg-exprs)
|
||||
(if (eq (first annotated-function-expr) 'expr-annotation:primitive)
|
||||
(let ((primitive (symbol-primitive (second annotated-function-expr))))
|
||||
(depict-expr-parentheses (markup-stream level (primitive-level primitive))
|
||||
(ecase (primitive-appearance primitive)
|
||||
(:global
|
||||
(depict-primitive markup-stream primitive)
|
||||
(depict-call-parameters markup-stream world annotated-arg-exprs))
|
||||
(:infix
|
||||
(assert-true (= (length annotated-arg-exprs) 2))
|
||||
(depict-logical-block (markup-stream 0)
|
||||
(depict-annotated-value-expr markup-stream world (first annotated-arg-exprs) (primitive-level1 primitive))
|
||||
(let ((spaces (primitive-markup2 primitive)))
|
||||
(when spaces
|
||||
(depict-space markup-stream))
|
||||
(depict-item-or-group-list markup-stream (primitive-markup1 primitive))
|
||||
(depict-break markup-stream (if spaces 1 0)))
|
||||
(depict-annotated-value-expr markup-stream world (second annotated-arg-exprs) (primitive-level2 primitive))))
|
||||
(:unary
|
||||
(assert-true (= (length annotated-arg-exprs) 1))
|
||||
(depict-item-or-group-list markup-stream (primitive-markup1 primitive))
|
||||
(depict-annotated-value-expr markup-stream world (first annotated-arg-exprs) (primitive-level1 primitive))
|
||||
(depict-item-or-group-list markup-stream (primitive-markup2 primitive)))
|
||||
(:phantom
|
||||
(assert-true (= (length annotated-arg-exprs) 1))
|
||||
(depict-annotated-value-expr markup-stream world (first annotated-arg-exprs) level)))))
|
||||
(depict-expr-parentheses (markup-stream level *primitive-level-unary-suffix*)
|
||||
(depict-annotated-value-expr markup-stream world annotated-function-expr *primitive-level-unary-suffix*)
|
||||
(depict-call-parameters markup-stream world annotated-arg-exprs))))
|
||||
|
||||
|
||||
; Emit markup for the reference to the action on the given general grammar symbol.
|
||||
(defun depict-action-reference (markup-stream action-name general-grammar-symbol &optional index)
|
||||
(depict-action-name markup-stream action-name)
|
||||
(depict markup-stream :action-begin)
|
||||
(depict-general-grammar-symbol markup-stream general-grammar-symbol index)
|
||||
(depict markup-stream :action-end))
|
||||
|
||||
|
||||
; Emit markup for the given annotated value expression. level indicates the binding level imposed
|
||||
; by the enclosing expression.
|
||||
(defun depict-annotated-value-expr (markup-stream world annotated-expr &optional (level *primitive-level-expr*))
|
||||
(let ((annotation (first annotated-expr))
|
||||
(args (rest annotated-expr)))
|
||||
(ecase annotation
|
||||
(expr-annotation:constant (depict-constant markup-stream (first args)))
|
||||
(expr-annotation:primitive (depict-primitive markup-stream (symbol-primitive (first args))))
|
||||
(expr-annotation:local (depict-local-variable markup-stream (first args)))
|
||||
(expr-annotation:global (depict-global-variable markup-stream (first args)))
|
||||
(expr-annotation:call (apply #'depict-call markup-stream world level args))
|
||||
(expr-annotation:action (apply #'depict-action-reference markup-stream args))
|
||||
(expr-annotation:special-form
|
||||
(apply (get (first args) :depict-special-form) markup-stream world level (rest args)))
|
||||
(expr-annotation:macro
|
||||
(let ((depictor (get (first args) :depict-macro)))
|
||||
(if depictor
|
||||
(apply depictor markup-stream world level (rest args))
|
||||
(depict-annotated-value-expr markup-stream world (second args) level)))))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; DEPICTING SPECIAL FORMS
|
||||
|
||||
(defmacro depict-statement ((markup-stream keyword &optional (space t)) &body body)
|
||||
`(depict-logical-block (,markup-stream 0)
|
||||
(when (< level *primitive-level-stmt*)
|
||||
(depict-break ,markup-stream))
|
||||
(depict-expr-parentheses (,markup-stream level *primitive-level-stmt*)
|
||||
(depict-semantic-keyword ,markup-stream ,keyword)
|
||||
,@(and space `((depict-space ,markup-stream)))
|
||||
,@body)))
|
||||
|
||||
|
||||
; (bottom <type>)
|
||||
(defun depict-bottom (markup-stream world level type-expr)
|
||||
(declare (ignore world level type-expr))
|
||||
(depict markup-stream ':bottom-10))
|
||||
|
||||
|
||||
(defun depict-lambda-bindings (markup-stream world arg-binding-exprs)
|
||||
(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
|
||||
:prefix "("
|
||||
:suffix ")"
|
||||
:separator ", "
|
||||
:empty nil))
|
||||
|
||||
; (lambda ((<var1> <type1> [:unused]) ... (<varn> <typen> [:unused])) <body>)
|
||||
(defun depict-lambda (markup-stream world level arg-binding-exprs body-annotated-expr)
|
||||
(depict-statement (markup-stream 'lambda nil)
|
||||
(depict-lambda-bindings markup-stream world arg-binding-exprs)
|
||||
(depict-logical-block (markup-stream 4)
|
||||
(depict-break markup-stream)
|
||||
(depict-annotated-value-expr markup-stream world body-annotated-expr *primitive-level-stmt*))))
|
||||
|
||||
|
||||
; (if <condition-expr> <true-expr> <false-expr>)
|
||||
(defun depict-if (markup-stream world level condition-annotated-expr true-annotated-expr false-annotated-expr)
|
||||
(depict-statement (markup-stream 'if)
|
||||
(depict-logical-block (markup-stream 4)
|
||||
(depict-annotated-value-expr markup-stream world condition-annotated-expr))
|
||||
(depict-break markup-stream)
|
||||
(depict-semantic-keyword markup-stream 'then)
|
||||
(depict-space markup-stream)
|
||||
(depict-logical-block (markup-stream 7)
|
||||
(depict-annotated-value-expr markup-stream world true-annotated-expr *primitive-level-stmt*))
|
||||
(depict-break markup-stream)
|
||||
(depict-semantic-keyword markup-stream 'else)
|
||||
(depict-space markup-stream)
|
||||
(depict-logical-block (markup-stream (if (special-form-annotated-expr? 'if false-annotated-expr) nil 6))
|
||||
(depict-annotated-value-expr markup-stream world false-annotated-expr *primitive-level-stmt*))))
|
||||
|
||||
|
||||
;;; Vectors
|
||||
|
||||
; (vector <element-expr> <element-expr> ... <element-expr>)
|
||||
(defun depict-vector-form (markup-stream world level &rest element-annotated-exprs)
|
||||
(declare (ignore level))
|
||||
(depict-list markup-stream
|
||||
#'(lambda (markup-stream element-annotated-expr)
|
||||
(depict-annotated-value-expr markup-stream world element-annotated-expr))
|
||||
element-annotated-exprs
|
||||
:indent 1
|
||||
:prefix ':vector-begin
|
||||
:suffix ':vector-end
|
||||
:separator ","
|
||||
:break 1))
|
||||
|
||||
|
||||
(defun depict-subscript-type-expr (markup-stream world type-expr)
|
||||
(depict-char-style (markup-stream 'sub)
|
||||
(depict-type-expr markup-stream world type-expr)))
|
||||
|
||||
|
||||
; (vector-of <element-type>)
|
||||
(defun depict-vector-of (markup-stream world level element-type-expr)
|
||||
(declare (ignore level))
|
||||
(depict markup-stream ':empty-vector)
|
||||
(depict-subscript-type-expr markup-stream world element-type-expr))
|
||||
|
||||
|
||||
(defun depict-special-function (markup-stream world name-str &rest arg-annotated-exprs)
|
||||
(depict-char-style (markup-stream :global-variable)
|
||||
(depict markup-stream name-str))
|
||||
(depict-call-parameters markup-stream world arg-annotated-exprs))
|
||||
|
||||
|
||||
; (empty <vector-expr>)
|
||||
(defun depict-empty (markup-stream world level vector-annotated-expr)
|
||||
(declare (ignore level))
|
||||
(depict-special-function markup-stream world "empty" vector-annotated-expr))
|
||||
|
||||
|
||||
; (length <vector-expr>)
|
||||
(defun depict-length (markup-stream world level vector-annotated-expr)
|
||||
(declare (ignore level))
|
||||
(depict-special-function markup-stream world "length" vector-annotated-expr))
|
||||
|
||||
|
||||
; (first <vector-expr>)
|
||||
(defun depict-first (markup-stream world level vector-annotated-expr)
|
||||
(declare (ignore level))
|
||||
(depict-special-function markup-stream world "first" vector-annotated-expr))
|
||||
|
||||
|
||||
; (last <vector-expr>)
|
||||
(defun depict-last (markup-stream world level vector-annotated-expr)
|
||||
(declare (ignore level))
|
||||
(depict-special-function markup-stream world "last" vector-annotated-expr))
|
||||
|
||||
|
||||
; (rest <vector-expr>)
|
||||
(defun depict-rest (markup-stream world level vector-annotated-expr)
|
||||
(declare (ignore level))
|
||||
(depict-special-function markup-stream world "rest" vector-annotated-expr))
|
||||
|
||||
|
||||
; (butlast <vector-expr>)
|
||||
(defun depict-butlast (markup-stream world level vector-annotated-expr)
|
||||
(declare (ignore level))
|
||||
(depict-special-function markup-stream world "butLast" vector-annotated-expr))
|
||||
|
||||
|
||||
; (nth <vector-expr> <n-expr>)
|
||||
(defun depict-nth (markup-stream world level vector-annotated-expr n-annotated-expr)
|
||||
(depict-expr-parentheses (markup-stream level *primitive-level-unary-suffix*)
|
||||
(depict-annotated-value-expr markup-stream world vector-annotated-expr *primitive-level-unary-suffix*)
|
||||
(depict markup-stream "[")
|
||||
(depict-annotated-value-expr markup-stream world n-annotated-expr)
|
||||
(depict markup-stream "]")))
|
||||
|
||||
|
||||
; (append <vector-expr> <vector-expr>)
|
||||
(defun depict-append (markup-stream world level vector1-annotated-expr vector2-annotated-expr)
|
||||
(depict-expr-parentheses (markup-stream level *primitive-level-additive*)
|
||||
(depict-logical-block (markup-stream 0)
|
||||
(depict-annotated-value-expr markup-stream world vector1-annotated-expr *primitive-level-additive*)
|
||||
(depict markup-stream " " :vector-append)
|
||||
(depict-break markup-stream 1)
|
||||
(depict-annotated-value-expr markup-stream world vector2-annotated-expr *primitive-level-additive*))))
|
||||
|
||||
|
||||
;;; Oneofs
|
||||
|
||||
; (oneof <oneof-type> <tag> <value-expr>)
|
||||
(defun depict-oneof-form (markup-stream world level tag &optional value-annotated-expr)
|
||||
(depict-expr-parentheses (markup-stream level *primitive-level-unary-prefix*)
|
||||
(depict-field-name markup-stream tag)
|
||||
(when value-annotated-expr
|
||||
(depict-logical-block (markup-stream 4)
|
||||
(depict-break markup-stream 1)
|
||||
(depict-annotated-value-expr markup-stream world value-annotated-expr *primitive-level-unary*)))))
|
||||
|
||||
|
||||
; (typed-oneof <type-expr> <tag> <value-expr>)
|
||||
(defun depict-typed-oneof (markup-stream world level type-expr tag &optional value-annotated-expr)
|
||||
(depict-expr-parentheses (markup-stream level *primitive-level-unary-prefix*)
|
||||
(depict-field-name markup-stream tag)
|
||||
(depict-subscript-type-expr markup-stream world type-expr)
|
||||
(when value-annotated-expr
|
||||
(depict-logical-block (markup-stream 4)
|
||||
(depict-break markup-stream 1)
|
||||
(depict-annotated-value-expr markup-stream world value-annotated-expr *primitive-level-unary*)))))
|
||||
|
||||
|
||||
; (case <oneof-expr> (<tag-spec> <value-expr>) (<tag-spec> <value-expr>) ... (<tag-spec> <value-expr>))
|
||||
; where each <tag-spec> is either ((<tag> <tag> ... <tag>) nil nil) or ((<tag>) <var> <type>)
|
||||
(defun depict-case (markup-stream world level oneof-annotated-expr &rest annotated-cases)
|
||||
(depict-statement (markup-stream 'case)
|
||||
(depict-logical-block (markup-stream 6)
|
||||
(depict-annotated-value-expr markup-stream world oneof-annotated-expr))
|
||||
(depict-space markup-stream)
|
||||
(depict-semantic-keyword markup-stream 'of)
|
||||
(depict-logical-block (markup-stream 3)
|
||||
(mapl #'(lambda (annotated-cases)
|
||||
(let* ((annotated-case (first annotated-cases))
|
||||
(tag-spec (first annotated-case))
|
||||
(tags (first tag-spec))
|
||||
(var (second tag-spec))
|
||||
(value-annotated-expr (second annotated-case)))
|
||||
(depict-break markup-stream)
|
||||
(depict-logical-block (markup-stream 6)
|
||||
(depict-list markup-stream
|
||||
#'depict-field-name
|
||||
tags
|
||||
:indent 0
|
||||
:separator ","
|
||||
:break 1)
|
||||
(when var
|
||||
(depict markup-stream "(")
|
||||
(depict-local-variable markup-stream var)
|
||||
(depict markup-stream ": ")
|
||||
(depict-type-expr markup-stream world (third tag-spec))
|
||||
(depict markup-stream ")"))
|
||||
(depict markup-stream ":")
|
||||
(depict-break markup-stream 1)
|
||||
(depict-annotated-value-expr markup-stream world value-annotated-expr *primitive-level-stmt*)
|
||||
(when (cdr annotated-cases)
|
||||
(depict markup-stream ";")))))
|
||||
annotated-cases)
|
||||
(depict-break markup-stream)
|
||||
(depict-semantic-keyword markup-stream 'end))))
|
||||
|
||||
|
||||
; (select <tag> <oneof-expr>)
|
||||
; (& <tag> <tuple-expr>)
|
||||
(defun depict-select-or-& (markup-stream world level tag annotated-expr)
|
||||
(depict-expr-parentheses (markup-stream level *primitive-level-unary-suffix*)
|
||||
(depict-annotated-value-expr markup-stream world annotated-expr *primitive-level-unary-suffix*)
|
||||
(depict markup-stream ".")
|
||||
(depict-field-name markup-stream tag)))
|
||||
|
||||
|
||||
; (is <tag> <oneof-expr>)
|
||||
(defun depict-is (markup-stream world level tag oneof-annotated-expr)
|
||||
(depict-expr-parentheses (markup-stream level *primitive-level-relational*)
|
||||
(depict-annotated-value-expr markup-stream world oneof-annotated-expr *primitive-level-unary-suffix*)
|
||||
(depict-space markup-stream)
|
||||
(depict-semantic-keyword markup-stream 'is)
|
||||
(depict-space markup-stream)
|
||||
(depict-field-name markup-stream tag)))
|
||||
|
||||
|
||||
;;; Tuples
|
||||
|
||||
; (tuple <tuple-type> <field-expr1> ... <field-exprn>)
|
||||
(defun depict-tuple-form (markup-stream world level type-expr &rest annotated-exprs)
|
||||
(declare (ignore level))
|
||||
(depict-list markup-stream
|
||||
#'(lambda (markup-stream parameter)
|
||||
(depict-annotated-value-expr markup-stream world parameter))
|
||||
annotated-exprs
|
||||
:indent 4
|
||||
:prefix ':tuple-begin
|
||||
:prefix-break 0
|
||||
:suffix ':tuple-end
|
||||
:separator ","
|
||||
:break 1
|
||||
:empty nil)
|
||||
(depict-subscript-type-expr markup-stream world type-expr))
|
||||
|
||||
|
||||
;;; Addresses
|
||||
|
||||
; (new <value-expr>)
|
||||
(defun depict-new (markup-stream world level value-annotated-expr)
|
||||
(depict-logical-block (markup-stream 5)
|
||||
(depict-semantic-keyword markup-stream 'new)
|
||||
(depict-space markup-stream)
|
||||
(depict-expr-parentheses (markup-stream level *primitive-level-unparenthesized-new*)
|
||||
(depict-annotated-value-expr markup-stream world value-annotated-expr
|
||||
(if (< level *primitive-level-unparenthesized-new*)
|
||||
*primitive-level-expr*
|
||||
*primitive-level-unary-prefix*)))))
|
||||
|
||||
|
||||
; (@ <address-expr>)
|
||||
(defun depict-@ (markup-stream world level address-annotated-expr)
|
||||
(depict-expr-parentheses (markup-stream level *primitive-level-unary-prefix*)
|
||||
(depict-logical-block (markup-stream 2)
|
||||
(depict markup-stream "@")
|
||||
(depict-annotated-value-expr markup-stream world address-annotated-expr *primitive-level-unary-prefix*))))
|
||||
|
||||
|
||||
; (@= <address-expr> <value-expr>)
|
||||
(defun depict-@= (markup-stream world level address-annotated-expr value-annotated-expr)
|
||||
(depict-expr-parentheses (markup-stream level *primitive-level-stmt*)
|
||||
(depict-logical-block (markup-stream 0)
|
||||
(depict markup-stream "@")
|
||||
(depict-annotated-value-expr markup-stream world address-annotated-expr *primitive-level-unary-prefix*)
|
||||
(depict markup-stream " :=")
|
||||
(depict-logical-block (markup-stream 6)
|
||||
(depict-break markup-stream 1)
|
||||
(depict-annotated-value-expr markup-stream world value-annotated-expr *primitive-level-stmt*)))))
|
||||
|
||||
|
||||
; (address-equal <address-expr1> <address-expr2>)
|
||||
(defun depict-address-equal (markup-stream world level address1-annotated-expr address2-annotated-expr)
|
||||
(depict-expr-parentheses (markup-stream level *primitive-level-relational*)
|
||||
(depict-logical-block (markup-stream 0)
|
||||
(depict-annotated-value-expr markup-stream world address1-annotated-expr *primitive-level-additive*)
|
||||
(depict markup-stream " " :identical-10)
|
||||
(depict-break markup-stream 1)
|
||||
(depict-annotated-value-expr markup-stream world address2-annotated-expr *primitive-level-additive*))))
|
||||
|
||||
|
||||
;;; Macros
|
||||
|
||||
(defun depict-let-binding (markup-stream world var type-expr value-annotated-expr)
|
||||
(depict-logical-block (markup-stream 4)
|
||||
(depict-local-variable markup-stream var)
|
||||
(depict markup-stream ": ")
|
||||
(depict-type-expr markup-stream world type-expr)
|
||||
(depict-break markup-stream 1)
|
||||
(depict-logical-block (markup-stream 3)
|
||||
(depict markup-stream "= ")
|
||||
(depict-annotated-value-expr markup-stream world value-annotated-expr *primitive-level-stmt*))))
|
||||
|
||||
|
||||
(defun depict-let-body (markup-stream world body-annotated-expr)
|
||||
(depict-break markup-stream)
|
||||
(depict-semantic-keyword markup-stream 'in)
|
||||
(depict-space markup-stream)
|
||||
(depict-logical-block (markup-stream (if (or (macro-annotated-expr? 'let body-annotated-expr)
|
||||
(macro-annotated-expr? 'letexc body-annotated-expr))
|
||||
nil
|
||||
4))
|
||||
(depict-annotated-value-expr markup-stream world body-annotated-expr *primitive-level-stmt*)))
|
||||
|
||||
|
||||
; (let ((<var1> <type1> <expr1> [:unused]) ... (<varn> <typen> <exprn> [:unused])) <body>) ==>
|
||||
; ((lambda ((<var1> <type1> [:unused]) ... (<varn> <typen> [:unused])) <body>) <expr1> ... <exprn>)
|
||||
(defun depict-let (markup-stream world level annotated-expansion)
|
||||
(assert-true (eq (first annotated-expansion) 'expr-annotation:call))
|
||||
(let ((lambda-annotated-expr (second annotated-expansion))
|
||||
(arg-annotated-exprs (cddr annotated-expansion)))
|
||||
(assert-true (special-form-annotated-expr? 'lambda lambda-annotated-expr))
|
||||
(let ((arg-binding-exprs (third lambda-annotated-expr))
|
||||
(body-annotated-expr (fourth lambda-annotated-expr)))
|
||||
(depict-statement (markup-stream 'let)
|
||||
(depict-list markup-stream
|
||||
#'(lambda (markup-stream arg-binding)
|
||||
(depict-let-binding markup-stream world (first arg-binding) (second arg-binding) (pop arg-annotated-exprs)))
|
||||
arg-binding-exprs
|
||||
:indent 4
|
||||
:separator ";"
|
||||
:break t
|
||||
:empty nil)
|
||||
(depict-let-body markup-stream world body-annotated-expr)))))
|
||||
|
||||
|
||||
; (letexc (<var> <type> <expr> [:unused]) <body>) ==>
|
||||
; (case <expr>
|
||||
; ((abrupt x exception) (typed-oneof <body-type> abrupt x))
|
||||
; ((normal <var> <type> [:unused]) <body>)))
|
||||
(defun depict-letexc (markup-stream world level annotated-expansion)
|
||||
(assert-true (special-form-annotated-expr? 'case annotated-expansion))
|
||||
(let* ((expr-annotated-expr (third annotated-expansion))
|
||||
(abrupt-binding (fourth annotated-expansion))
|
||||
(abrupt-tag-spec (first abrupt-binding))
|
||||
(normal-binding (fifth annotated-expansion))
|
||||
(normal-tag-spec (first normal-binding)))
|
||||
(assert-true (equal (first abrupt-tag-spec) '(abrupt)))
|
||||
(assert-true (equal (first normal-tag-spec) '(normal)))
|
||||
(let* ((var (second normal-tag-spec))
|
||||
(type-expr (third normal-tag-spec))
|
||||
(body-annotated-expr (second normal-binding)))
|
||||
(depict-statement (markup-stream 'letexc)
|
||||
(depict-logical-block (markup-stream 9)
|
||||
(depict-let-binding markup-stream world var type-expr expr-annotated-expr))
|
||||
(depict-let-body markup-stream world body-annotated-expr)))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; DEPICTING COMMANDS
|
||||
|
||||
|
||||
(defmacro depict-semantics ((markup-stream depict-env &optional (paragraph-style ':semantics)) &body body)
|
||||
`(progn
|
||||
(depict-mode ,markup-stream ,depict-env :semantics)
|
||||
(depict-paragraph (,markup-stream ,paragraph-style)
|
||||
,@body)))
|
||||
|
||||
|
||||
; (%section "section-name")
|
||||
(defun depict-%section (markup-stream world depict-env section-name)
|
||||
(declare (ignore world))
|
||||
(assert-type section-name string)
|
||||
(depict-mode markup-stream depict-env nil)
|
||||
(depict-paragraph (markup-stream :section-heading)
|
||||
(depict markup-stream section-name)))
|
||||
|
||||
|
||||
; (%subsection "subsection-name")
|
||||
(defun depict-%subsection (markup-stream world depict-env section-name)
|
||||
(declare (ignore world))
|
||||
(assert-type section-name string)
|
||||
(depict-mode markup-stream depict-env nil)
|
||||
(depict-paragraph (markup-stream :subsection-heading)
|
||||
(depict markup-stream section-name)))
|
||||
|
||||
|
||||
; (grammar-argument <argument> <attribute> <attribute> ... <attribute>)
|
||||
(defun depict-grammar-argument (markup-stream world depict-env argument &rest attributes)
|
||||
(declare (ignore world))
|
||||
(depict-mode markup-stream depict-env :syntax)
|
||||
(depict-paragraph (markup-stream :grammar-argument)
|
||||
(depict-nonterminal-argument markup-stream argument)
|
||||
(depict markup-stream " " :member-10 " ")
|
||||
(depict-list markup-stream
|
||||
#'(lambda (markup-stream attribute)
|
||||
(depict-nonterminal-attribute markup-stream attribute))
|
||||
attributes
|
||||
:prefix "{"
|
||||
:suffix "}"
|
||||
:separator ", ")))
|
||||
|
||||
|
||||
; (%rule <general-nonterminal-source>)
|
||||
(defun depict-%rule (markup-stream world depict-env general-nonterminal-source)
|
||||
(declare (ignore world))
|
||||
(let* ((grammar-info (checked-depict-env-grammar-info depict-env))
|
||||
(grammar (grammar-info-grammar grammar-info))
|
||||
(general-nonterminal (grammar-parametrization-intern grammar general-nonterminal-source))
|
||||
(seen-nonterminals (depict-env-seen-nonterminals depict-env)))
|
||||
(when (grammar-info-charclass grammar-info general-nonterminal)
|
||||
(error "Shouldn't use %rule on a lexer charclass nonterminal ~S" general-nonterminal))
|
||||
(labels
|
||||
((seen-nonterminal? (nonterminal)
|
||||
(gethash nonterminal seen-nonterminals)))
|
||||
(unless (every #'seen-nonterminal? (general-grammar-symbol-instances grammar general-nonterminal))
|
||||
(depict-mode markup-stream depict-env :syntax)
|
||||
(dolist (general-rule (grammar-general-rules grammar general-nonterminal))
|
||||
(let ((rule-lhs-nonterminals (general-grammar-symbol-instances grammar (general-rule-lhs general-rule))))
|
||||
(unless (every #'seen-nonterminal? rule-lhs-nonterminals)
|
||||
(when (some #'seen-nonterminal? rule-lhs-nonterminals)
|
||||
(warn "General rule for ~S listed before specific ones; use %rule to disambiguate" general-nonterminal))
|
||||
(depict-general-rule markup-stream general-rule)
|
||||
(dolist (nonterminal rule-lhs-nonterminals)
|
||||
(setf (gethash nonterminal seen-nonterminals) t)))))))))
|
||||
;******** May still have a problem when a specific rule precedes a general one.
|
||||
|
||||
|
||||
; (%charclass <nonterminal>)
|
||||
(defun depict-%charclass (markup-stream world depict-env nonterminal)
|
||||
(let* ((grammar-info (checked-depict-env-grammar-info depict-env))
|
||||
(charclass (grammar-info-charclass grammar-info nonterminal)))
|
||||
(unless charclass
|
||||
(error "%charclass with a non-charclass ~S" nonterminal))
|
||||
(if (gethash nonterminal (depict-env-seen-nonterminals depict-env))
|
||||
(warn "Duplicate charclass ~S" nonterminal)
|
||||
(progn
|
||||
(depict-mode markup-stream depict-env :syntax)
|
||||
(depict-charclass markup-stream charclass)
|
||||
(dolist (action-cons (charclass-actions charclass))
|
||||
(depict-charclass-action world depict-env (cdr action-cons) nonterminal))
|
||||
(setf (gethash nonterminal (depict-env-seen-nonterminals depict-env)) t)))))
|
||||
|
||||
|
||||
; (%print-actions)
|
||||
(defun depict-%print-actions (markup-stream world depict-env)
|
||||
(declare (ignore world))
|
||||
(dolist (pending-action (nreverse (depict-env-pending-actions-reverse depict-env)))
|
||||
(funcall pending-action markup-stream depict-env))
|
||||
(setf (depict-env-pending-actions-reverse depict-env) nil))
|
||||
|
||||
|
||||
; (deftype <name> <type>)
|
||||
(defun depict-deftype (markup-stream world depict-env name type-expr)
|
||||
(depict-semantics (markup-stream depict-env)
|
||||
(depict-logical-block (markup-stream 2)
|
||||
(depict-semantic-keyword markup-stream 'type)
|
||||
(depict-space markup-stream)
|
||||
(depict-type-name markup-stream name)
|
||||
(depict-break markup-stream 1)
|
||||
(depict-logical-block (markup-stream 3)
|
||||
(depict markup-stream "= ")
|
||||
(depict-type-expr markup-stream world type-expr)))))
|
||||
|
||||
|
||||
; (define <name> <type> <value> <destructured>)
|
||||
; <destructured> is a flag that is true if this define was originally in the form
|
||||
; (define (<name> (<arg1> <type1>) ... (<argn> <typen>)) <result-type> <value>)
|
||||
; and converted into
|
||||
; (define <name> (-> (<type1> ... <typen>) <result-type>)
|
||||
; (lambda ((<arg1> <type1>) ... (<argn> <typen>)) <value>)
|
||||
; t)
|
||||
(defun depict-define (markup-stream world depict-env name type-expr value-expr destructured)
|
||||
(depict-semantics (markup-stream depict-env)
|
||||
(depict-logical-block (markup-stream 2)
|
||||
(depict-global-variable markup-stream name)
|
||||
(flet
|
||||
((depict-type-and-value (markup-stream type-expr annotated-value-expr)
|
||||
(depict-logical-block (markup-stream 0)
|
||||
(depict-break markup-stream 1)
|
||||
(depict markup-stream ": ")
|
||||
(depict-type-expr markup-stream world type-expr))
|
||||
(depict-break markup-stream 1)
|
||||
(depict-logical-block (markup-stream 3)
|
||||
(depict markup-stream "= ")
|
||||
(depict-annotated-value-expr markup-stream world annotated-value-expr *primitive-level-max*))))
|
||||
|
||||
(let ((annotated-value-expr (nth-value 2 (scan-value world *null-type-env* value-expr))))
|
||||
(if destructured
|
||||
(progn
|
||||
(assert-true (eq (first type-expr) '->))
|
||||
(assert-true (special-form-annotated-expr? 'lambda annotated-value-expr))
|
||||
(depict-lambda-bindings markup-stream world (third annotated-value-expr))
|
||||
(depict-type-and-value markup-stream (third type-expr) (fourth annotated-value-expr)))
|
||||
(depict-type-and-value markup-stream type-expr annotated-value-expr)))))))
|
||||
|
||||
|
||||
; (set-grammar <name>)
|
||||
(defun depict-set-grammar (markup-stream world depict-env name)
|
||||
(depict-clear-grammar markup-stream world depict-env)
|
||||
(let ((grammar-info (world-grammar-info world name)))
|
||||
(unless grammar-info
|
||||
(error "Unknown grammar ~A" name))
|
||||
(setf (depict-env-grammar-info depict-env) grammar-info)
|
||||
(setf (depict-env-seen-nonterminals depict-env) (make-hash-table :test #'eq))))
|
||||
|
||||
|
||||
; (clear-grammar)
|
||||
(defun depict-clear-grammar (markup-stream world depict-env)
|
||||
(depict-%print-actions markup-stream world depict-env)
|
||||
(depict-mode markup-stream depict-env nil)
|
||||
(let ((grammar-info (depict-env-grammar-info depict-env)))
|
||||
(when grammar-info
|
||||
(let ((seen-nonterminals (depict-env-seen-nonterminals depict-env))
|
||||
(missed-nonterminals nil))
|
||||
(dolist (nonterminal (grammar-nonterminals-list (grammar-info-grammar grammar-info)))
|
||||
(unless (or (gethash nonterminal seen-nonterminals)
|
||||
(eq nonterminal *start-nonterminal*))
|
||||
(push nonterminal missed-nonterminals)))
|
||||
(when missed-nonterminals
|
||||
(warn "Nonterminals not printed: ~S" missed-nonterminals)))
|
||||
(setf (depict-env-grammar-info depict-env) nil)
|
||||
(setf (depict-env-seen-nonterminals depict-env) nil))))
|
||||
|
||||
|
||||
(defmacro depict-delayed-action ((markup-stream depict-env) &body depictor)
|
||||
`(push #'(lambda (,markup-stream ,depict-env) ,@depictor)
|
||||
(depict-env-pending-actions-reverse ,depict-env)))
|
||||
|
||||
|
||||
(defun depict-declare-action-contents (markup-stream world action-name general-grammar-symbol type-expr)
|
||||
(depict-semantic-keyword markup-stream 'action)
|
||||
(depict-space markup-stream)
|
||||
(depict-action-name markup-stream action-name)
|
||||
(depict markup-stream :action-begin)
|
||||
(depict-general-grammar-symbol markup-stream general-grammar-symbol)
|
||||
(depict markup-stream :action-end)
|
||||
(depict-break markup-stream 1)
|
||||
(depict-logical-block (markup-stream 2)
|
||||
(depict markup-stream ": ")
|
||||
(depict-type-expr markup-stream world type-expr)))
|
||||
|
||||
|
||||
; (declare-action <action-name> <general-grammar-symbol> <type>)
|
||||
(defun depict-declare-action (markup-stream world depict-env action-name general-grammar-symbol-source type-expr)
|
||||
(declare (ignore markup-stream))
|
||||
(let* ((grammar-info (checked-depict-env-grammar-info depict-env))
|
||||
(general-grammar-symbol (grammar-parametrization-intern (grammar-info-grammar grammar-info) general-grammar-symbol-source)))
|
||||
(unless (grammar-info-charclass-or-partition grammar-info general-grammar-symbol)
|
||||
(depict-delayed-action (markup-stream depict-env)
|
||||
(depict-semantics (markup-stream depict-env)
|
||||
(depict-logical-block (markup-stream 4)
|
||||
(depict-declare-action-contents markup-stream world action-name general-grammar-symbol type-expr)))))))
|
||||
|
||||
|
||||
; Declare and define the lexer-action on the charclass given by nonterminal.
|
||||
(defun depict-charclass-action (world depict-env lexer-action nonterminal)
|
||||
(depict-delayed-action (markup-stream depict-env)
|
||||
(depict-semantics (markup-stream depict-env)
|
||||
(depict-logical-block (markup-stream 4)
|
||||
(depict-declare-action-contents markup-stream world (lexer-action-name lexer-action)
|
||||
nonterminal (lexer-action-type-expr lexer-action))
|
||||
(depict-break markup-stream 1)
|
||||
(depict-logical-block (markup-stream 3)
|
||||
(depict markup-stream "= ")
|
||||
(depict-lexer-action markup-stream lexer-action nonterminal))))))
|
||||
|
||||
|
||||
; (action <action-name> <production-name> <body>)
|
||||
; <destructured> is a flag that is true if this define was originally in the form
|
||||
; (action (<action-name> (<arg1> <type1>) ... (<argn> <typen>)) <production-name> <body>)
|
||||
; and converted into
|
||||
; (action <action-name> <production-name> (lambda ((<arg1> <type1>) ... (<argn> <typen>)) <body>) t)
|
||||
(defun depict-action (markup-stream world depict-env action-name production-name body-expr destructured)
|
||||
(declare (ignore markup-stream))
|
||||
(let* ((grammar-info (checked-depict-env-grammar-info depict-env))
|
||||
(grammar (grammar-info-grammar grammar-info))
|
||||
(general-production (grammar-general-production grammar production-name)))
|
||||
(unless (grammar-info-charclass grammar-info (general-production-lhs general-production))
|
||||
(depict-delayed-action (markup-stream depict-env)
|
||||
(depict-semantics (markup-stream depict-env :semantics-next)
|
||||
(depict-logical-block (markup-stream 2)
|
||||
(let* ((initial-env (general-production-action-env grammar general-production))
|
||||
(body-annotated-expr (nth-value 2 (scan-value world initial-env body-expr)))
|
||||
(action-grammar-symbols (annotated-expr-grammar-symbols body-annotated-expr)))
|
||||
(depict-action-name markup-stream action-name)
|
||||
(depict markup-stream :action-begin)
|
||||
(depict-general-production markup-stream general-production action-grammar-symbols)
|
||||
(depict markup-stream :action-end)
|
||||
(flet
|
||||
((depict-body (markup-stream body-annotated-expr)
|
||||
(depict-break markup-stream 1)
|
||||
(depict-logical-block (markup-stream 3)
|
||||
(depict markup-stream "= ")
|
||||
(depict-annotated-value-expr markup-stream world body-annotated-expr *primitive-level-stmt*))))
|
||||
|
||||
(if destructured
|
||||
(progn
|
||||
(assert-true (special-form-annotated-expr? 'lambda body-annotated-expr))
|
||||
(depict-logical-block (markup-stream 10)
|
||||
(depict-break markup-stream 0)
|
||||
(depict-lambda-bindings markup-stream world (third body-annotated-expr)))
|
||||
(depict-body markup-stream (fourth body-annotated-expr)))
|
||||
(depict-body markup-stream body-annotated-expr))))))))))
|
||||
|
||||
|
||||
; (terminal-action <action-name> <terminal> <lisp-function-name>)
|
||||
(defun depict-terminal-action (markup-stream world depict-env action-name terminal function-name)
|
||||
(declare (ignore markup-stream world depict-env action-name terminal function-name)))
|
||||
Разница между файлами не показана из-за своего большого размера
Загрузить разницу
|
|
@ -0,0 +1,483 @@
|
|||
;;; The contents of this file are subject to the Netscape Public License
|
||||
;;; Version 1.0 (the "NPL"); you may not use this file except in
|
||||
;;; compliance with the NPL. You may obtain a copy of the NPL at
|
||||
;;; http://www.mozilla.org/NPL/
|
||||
;;;
|
||||
;;; Software distributed under the NPL is distributed on an "AS IS" basis,
|
||||
;;; WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
|
||||
;;; for the specific language governing rights and limitations under the
|
||||
;;; NPL.
|
||||
;;;
|
||||
;;; The Initial Developer of this code under the NPL is Netscape
|
||||
;;; Communications Corporation. Portions created by Netscape are
|
||||
;;; Copyright (C) 1998 Netscape Communications Corporation. All Rights
|
||||
;;; Reserved.
|
||||
|
||||
;;;
|
||||
;;; LALR(1) and LR(1) parametrized grammar utilities
|
||||
;;;
|
||||
;;; Waldemar Horwat (waldemar@netscape.com)
|
||||
;;;
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; UTILITIES
|
||||
|
||||
(declaim (inline identifier?))
|
||||
(defun identifier? (form)
|
||||
(and form (symbolp form) (not (keywordp form))))
|
||||
|
||||
(deftype identifier () '(satisfies identifier?))
|
||||
|
||||
|
||||
; Make sure that form is one of the following:
|
||||
; A symbol
|
||||
; An integer
|
||||
; A float
|
||||
; A character
|
||||
; A string
|
||||
; A list of zero or more forms that also satisfy ensure-proper-form;
|
||||
; the list cannot be dotted.
|
||||
; Return the form.
|
||||
(defun ensure-proper-form (form)
|
||||
(labels
|
||||
((ensure-list-form (form)
|
||||
(or (null form)
|
||||
(and (consp form)
|
||||
(progn
|
||||
(ensure-proper-form (car form))
|
||||
(ensure-list-form (cdr form)))))))
|
||||
(unless
|
||||
(or (symbolp form)
|
||||
(integerp form)
|
||||
(floatp form)
|
||||
(characterp form)
|
||||
(stringp form)
|
||||
(ensure-list-form form))
|
||||
(error "Bad form: ~S" form))
|
||||
form))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; TERMINALS
|
||||
|
||||
; A terminal is any of the following:
|
||||
; A symbol that is neither nil nor a keyword
|
||||
; A string;
|
||||
; A character;
|
||||
; An integer.
|
||||
(defun terminal? (x)
|
||||
(and x
|
||||
(or (and (symbolp x) (not (keywordp x)))
|
||||
(stringp x)
|
||||
(characterp x)
|
||||
(integerp x))))
|
||||
|
||||
; The following terminals are reserved and may not be used in user input:
|
||||
; $$ Marker for end of token stream
|
||||
(defconstant *end-marker* '$$)
|
||||
(defconstant *end-marker-terminal-number* 0)
|
||||
|
||||
(deftype terminal () '(satisfies terminal?))
|
||||
(deftype user-terminal () `(and terminal (not (eql ,*end-marker*))))
|
||||
|
||||
|
||||
; Emit markup for a terminal. subscript is an optional integer.
|
||||
(defun depict-terminal (markup-stream terminal &optional subscript)
|
||||
(cond
|
||||
((characterp terminal)
|
||||
(depict-char-style (markup-stream ':character-literal)
|
||||
(depict-character markup-stream terminal)
|
||||
(when subscript
|
||||
(depict-char-style (markup-stream ':plain-subscript)
|
||||
(depict-integer markup-stream subscript)))))
|
||||
((and terminal (symbolp terminal))
|
||||
(let ((name (symbol-name terminal)))
|
||||
(if (and (> (length name) 0) (char= (char name 0) #\$))
|
||||
(depict-char-style (markup-stream ':terminal)
|
||||
(depict markup-stream (subseq (symbol-upper-mixed-case-name terminal) 1))
|
||||
(when subscript
|
||||
(depict-char-style (markup-stream ':plain-subscript)
|
||||
(depict-integer markup-stream subscript))))
|
||||
(progn
|
||||
(depict-char-style (markup-stream ':terminal-keyword)
|
||||
(depict markup-stream (string-downcase name)))
|
||||
(when subscript
|
||||
(depict-char-style (markup-stream ':terminal)
|
||||
(depict-char-style (markup-stream ':plain-subscript)
|
||||
(depict-integer markup-stream subscript))))))))
|
||||
(t (error "Don't know how to emit markup for terminal ~S" terminal))))
|
||||
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; NONTERMINAL PARAMETERS
|
||||
|
||||
(declaim (inline nonterminal-parameter?))
|
||||
(defun nonterminal-parameter? (x)
|
||||
(symbolp x))
|
||||
(deftype nonterminal-parameter () 'symbol)
|
||||
|
||||
|
||||
; Return true if this nonterminal parameter is a constant.
|
||||
(declaim (inline nonterminal-attribute?))
|
||||
(defun nonterminal-attribute? (parameter)
|
||||
(and (symbolp parameter) (not (keywordp parameter))))
|
||||
(deftype nonterminal-attribute () '(and symbol (not keyword)))
|
||||
|
||||
|
||||
(defun depict-nonterminal-attribute (markup-stream attribute)
|
||||
(depict-char-style (markup-stream ':nonterminal)
|
||||
(depict-char-style (markup-stream ':nonterminal-attribute)
|
||||
(depict markup-stream (symbol-lower-mixed-case-name attribute)))))
|
||||
|
||||
|
||||
; Return true if this nonterminal parameter is a variable.
|
||||
(declaim (inline nonterminal-argument?))
|
||||
(defun nonterminal-argument? (parameter)
|
||||
(keywordp parameter))
|
||||
(deftype nonterminal-argument () 'keyword)
|
||||
|
||||
|
||||
(defparameter *special-nonterminal-arguments*
|
||||
'(:alpha :beta :gamma :delta :epsilon :zeta :eta :theta :iota :kappa :lambda :mu :nu
|
||||
:xi :omicron :pi :rho :sigma :tau :upsilon :phi :chi :psi :omega))
|
||||
|
||||
(defun depict-nonterminal-argument-symbol (markup-stream argument)
|
||||
(depict-char-style (markup-stream ':nonterminal-argument)
|
||||
(depict markup-stream
|
||||
(if (member argument *special-nonterminal-arguments*)
|
||||
argument
|
||||
(symbol-upper-mixed-case-name argument)))))
|
||||
|
||||
(defun depict-nonterminal-argument (markup-stream argument)
|
||||
(depict-char-style (markup-stream ':nonterminal)
|
||||
(depict-nonterminal-argument-symbol markup-stream argument)))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; ATTRIBUTED NONTERMINALS
|
||||
|
||||
; An attributed-nonterminal is a specific instantiation of a generic-nonterminal.
|
||||
(defstruct (attributed-nonterminal (:constructor allocate-attributed-nonterminal (symbol attributes))
|
||||
(:copier nil)
|
||||
(:predicate attributed-nonterminal?))
|
||||
(symbol nil :type keyword :read-only t) ;The name of the attributed nonterminal
|
||||
(attributes nil :type list :read-only t)) ;Ordered list of nonterminal attributes
|
||||
|
||||
|
||||
; Make an attributed nonterminal with the given symbol and attributes. If there
|
||||
; are no attributes, return the symbol as a plain nonterminal.
|
||||
; Nonterminals are eq whenever they have identical symbols and attribute lists.
|
||||
(defun make-attributed-nonterminal (symbol attributes)
|
||||
(assert-type symbol keyword)
|
||||
(assert-type attributes (list nonterminal-attribute))
|
||||
(if attributes
|
||||
(let ((generic-nonterminals (get symbol 'generic-nonterminals)))
|
||||
(or (cdr (assoc attributes generic-nonterminals :test #'equal))
|
||||
(let ((attributed-nonterminal (allocate-attributed-nonterminal symbol attributes)))
|
||||
(setf (get symbol 'generic-nonterminals)
|
||||
(acons attributes attributed-nonterminal generic-nonterminals))
|
||||
attributed-nonterminal)))
|
||||
symbol))
|
||||
|
||||
|
||||
(defmethod print-object ((attributed-nonterminal attributed-nonterminal) stream)
|
||||
(print-unreadable-object (attributed-nonterminal stream)
|
||||
(format stream "a ~@_~W~{ ~:_~W~}"
|
||||
(attributed-nonterminal-symbol attributed-nonterminal)
|
||||
(attributed-nonterminal-attributes attributed-nonterminal))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; GENERIC NONTERMINALS
|
||||
|
||||
; A generic-nonterminal is a parametrized nonterminal that can expand into two or more
|
||||
; attributed-nonterminals.
|
||||
(defstruct (generic-nonterminal (:constructor allocate-generic-nonterminal (symbol parameters))
|
||||
(:copier nil)
|
||||
(:predicate generic-nonterminal?))
|
||||
(symbol nil :type keyword :read-only t) ;The name of the generic nonterminal
|
||||
(parameters nil :type list :read-only t)) ;Ordered list of nonterminal attributes or arguments
|
||||
|
||||
|
||||
; Make a generic nonterminal with the given symbol and parameters. If none of
|
||||
; the parameters is an argument, make an attributed nonterminal instead. If there
|
||||
; are no parameters, return the symbol as a plain nonterminal.
|
||||
; Nonterminals are eq whenever they have identical symbols and parameter lists.
|
||||
(defun make-generic-nonterminal (symbol parameters)
|
||||
(assert-type symbol keyword)
|
||||
(if parameters
|
||||
(let ((generic-nonterminals (get symbol 'generic-nonterminals)))
|
||||
(or (cdr (assoc parameters generic-nonterminals :test #'equal))
|
||||
(progn
|
||||
(assert-type parameters (list nonterminal-parameter))
|
||||
(let ((generic-nonterminal (if (every #'nonterminal-attribute? parameters)
|
||||
(allocate-attributed-nonterminal symbol parameters)
|
||||
(allocate-generic-nonterminal symbol parameters))))
|
||||
(setf (get symbol 'generic-nonterminals)
|
||||
(acons parameters generic-nonterminal generic-nonterminals))
|
||||
generic-nonterminal))))
|
||||
symbol))
|
||||
|
||||
|
||||
(defmethod print-object ((generic-nonterminal generic-nonterminal) stream)
|
||||
(print-unreadable-object (generic-nonterminal stream)
|
||||
(format stream "g ~@_~W~{ ~:_~W~}"
|
||||
(generic-nonterminal-symbol generic-nonterminal)
|
||||
(generic-nonterminal-parameters generic-nonterminal))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; NONTERMINALS
|
||||
|
||||
;;; A nonterminal is a keyword or an attributed-nonterminal.
|
||||
(declaim (inline nonterminal?))
|
||||
(defun nonterminal? (x)
|
||||
(or (keywordp x) (attributed-nonterminal? x)))
|
||||
|
||||
; The following nonterminals are reserved and may not be used in user input:
|
||||
; :% Nonterminal that expands to the start nonterminal
|
||||
|
||||
(defconstant *start-nonterminal* :%)
|
||||
|
||||
(deftype nonterminal () '(or keyword attributed-nonterminal))
|
||||
(deftype user-nonterminal () `(and nonterminal (not (eql ,*start-nonterminal*))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; GENERAL NONTERMINALS
|
||||
|
||||
;;; A general-nonterminal is a nonterminal or a generic-nonterminal.
|
||||
(declaim (inline general-nonterminal?))
|
||||
(defun general-nonterminal? (x)
|
||||
(or (nonterminal? x) (generic-nonterminal? x)))
|
||||
|
||||
(deftype general-nonterminal () '(or nonterminal generic-nonterminal))
|
||||
|
||||
|
||||
; Return the list of parameters in the general-nonterminal. The list is empty if the
|
||||
; general-nonterminal is a plain nonterminal.
|
||||
(defun general-nonterminal-parameters (general-nonterminal)
|
||||
(cond
|
||||
((attributed-nonterminal? general-nonterminal) (attributed-nonterminal-attributes general-nonterminal))
|
||||
((generic-nonterminal? general-nonterminal) (generic-nonterminal-parameters general-nonterminal))
|
||||
(t (progn
|
||||
(assert-true (keywordp general-nonterminal))
|
||||
nil))))
|
||||
|
||||
|
||||
; Emit markup for a general-nonterminal. subscript is an optional integer.
|
||||
(defun depict-general-nonterminal (markup-stream general-nonterminal &optional subscript)
|
||||
(depict-char-style (markup-stream ':nonterminal)
|
||||
(labels
|
||||
((depict-nonterminal-parameter (markup-stream parameter)
|
||||
(if (nonterminal-attribute? parameter)
|
||||
(depict-char-style (markup-stream ':nonterminal-attribute)
|
||||
(depict markup-stream (symbol-lower-mixed-case-name parameter)))
|
||||
(depict-nonterminal-argument-symbol markup-stream parameter)))
|
||||
|
||||
(depict-parametrized-nonterminal (symbol parameters)
|
||||
(depict markup-stream (symbol-upper-mixed-case-name symbol))
|
||||
(depict-char-style (markup-stream ':superscript)
|
||||
(depict-list markup-stream #'depict-nonterminal-parameter parameters
|
||||
:separator ","))))
|
||||
|
||||
(cond
|
||||
((keywordp general-nonterminal)
|
||||
(depict markup-stream (symbol-upper-mixed-case-name general-nonterminal)))
|
||||
((attributed-nonterminal? general-nonterminal)
|
||||
(depict-parametrized-nonterminal (attributed-nonterminal-symbol general-nonterminal)
|
||||
(attributed-nonterminal-attributes general-nonterminal)))
|
||||
((generic-nonterminal? general-nonterminal)
|
||||
(depict-parametrized-nonterminal (generic-nonterminal-symbol general-nonterminal)
|
||||
(generic-nonterminal-parameters general-nonterminal)))
|
||||
(t (error "Bad nonterminal ~S" general-nonterminal)))
|
||||
(when subscript
|
||||
(depict-char-style (markup-stream ':plain-subscript)
|
||||
(depict-integer markup-stream subscript))))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; GRAMMAR SYMBOLS
|
||||
|
||||
;;; A grammar-symbol is either a terminal or a nonterminal.
|
||||
(deftype grammar-symbol () '(or terminal nonterminal))
|
||||
(deftype user-grammar-symbol () '(or user-terminal user-nonterminal))
|
||||
|
||||
;;; A general-grammar-symbol is either a terminal or a general-nonterminal.
|
||||
(deftype general-grammar-symbol () '(or terminal general-nonterminal))
|
||||
|
||||
|
||||
; Return true if the two grammar symbols are the same symbol.
|
||||
(declaim (inline grammar-symbol-=))
|
||||
(defun grammar-symbol-= (grammar-symbol1 grammar-symbol2)
|
||||
(eql grammar-symbol1 grammar-symbol2))
|
||||
; A version of grammar-symbol-= suitable for being the test function for hash tables.
|
||||
(defconstant *grammar-symbol-=* #'eql)
|
||||
|
||||
|
||||
; Return the general-grammar-symbol's symbol. Return it unchanged if it is not
|
||||
; an attributed or generic nonterminal.
|
||||
(defun general-grammar-symbol-symbol (general-grammar-symbol)
|
||||
(cond
|
||||
((attributed-nonterminal? general-grammar-symbol) (attributed-nonterminal-symbol general-grammar-symbol))
|
||||
((generic-nonterminal? general-grammar-symbol) (generic-nonterminal-symbol general-grammar-symbol))
|
||||
(t (assert-type general-grammar-symbol (or keyword terminal)))))
|
||||
|
||||
|
||||
; Return the list of arguments in the general-grammar-symbol. The list is empty if the
|
||||
; general-grammar-symbol is not a generic nonterminal.
|
||||
(defun general-grammar-symbol-arguments (general-grammar-symbol)
|
||||
(and (generic-nonterminal? general-grammar-symbol)
|
||||
(remove-if (complement #'nonterminal-argument?) (generic-nonterminal-parameters general-grammar-symbol))))
|
||||
|
||||
|
||||
; Emit markup for a general-grammar-symbol. subscript is an optional integer.
|
||||
(defun depict-general-grammar-symbol (markup-stream general-grammar-symbol &optional subscript)
|
||||
(if (general-nonterminal? general-grammar-symbol)
|
||||
(depict-general-nonterminal markup-stream general-grammar-symbol subscript)
|
||||
(depict-terminal markup-stream general-grammar-symbol subscript)))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; GRAMMAR PARAMETRIZATIONS
|
||||
|
||||
; A grammar parametrization holds the rules for converting nonterminal arguments into nonterminal attributes.
|
||||
(defstruct (grammar-parametrization (:constructor allocate-grammar-parametrization (argument-attributes))
|
||||
(:predicate grammar-parametrization?))
|
||||
(argument-attributes nil :type hash-table :read-only t)) ;Hash table of nonterminal-argument -> list of nonterminal-attributes
|
||||
|
||||
|
||||
(defun make-grammar-parametrization ()
|
||||
(allocate-grammar-parametrization (make-hash-table :test #'eq)))
|
||||
|
||||
|
||||
; Declare that nonterminal arguments with the given name can hold any of the
|
||||
; given nonterminal attributes given. At least one attribute must be provided.
|
||||
(defun grammar-parametrization-declare-argument (grammar-parametrization argument attributes)
|
||||
(assert-type argument nonterminal-argument)
|
||||
(assert-type attributes (list nonterminal-attribute))
|
||||
(assert-true attributes)
|
||||
(when (gethash argument (grammar-parametrization-argument-attributes grammar-parametrization))
|
||||
(error "Duplicate parametrized grammar argument ~S" argument))
|
||||
(setf (gethash argument (grammar-parametrization-argument-attributes grammar-parametrization)) attributes))
|
||||
|
||||
|
||||
; Return the attributes to which the given argument may expand.
|
||||
(defun grammar-parametrization-lookup-argument (grammar-parametrization argument)
|
||||
(assert-non-null (gethash argument (grammar-parametrization-argument-attributes grammar-parametrization))))
|
||||
|
||||
|
||||
; Create a plain, attributed, or generic grammar symbol from the specification in grammar-symbol-source.
|
||||
; If grammar-symbol-source is not a cons, it is a plain grammar symbol. If it is a list, its first element
|
||||
; must be a keyword that is a nonterminal's symbol and the other elements must be nonterminal
|
||||
; parameters.
|
||||
; Return two values:
|
||||
; the grammar symbol
|
||||
; a list of arguments used in the grammar symbol.
|
||||
; If allowed-arguments is given, check that each argument is in the allowed-arguments list;
|
||||
; if not, allow any arguments declared in grammar-parametrization but do not allow duplicates.
|
||||
(defun grammar-parametrization-intern (grammar-parametrization grammar-symbol-source &optional (allowed-arguments nil allow-duplicates))
|
||||
(if (consp grammar-symbol-source)
|
||||
(progn
|
||||
(assert-type grammar-symbol-source (cons keyword (list nonterminal-parameter)))
|
||||
(let* ((symbol (car grammar-symbol-source))
|
||||
(parameters (cdr grammar-symbol-source))
|
||||
(arguments (remove-if (complement #'nonterminal-argument?) parameters)))
|
||||
(mapl #'(lambda (arguments)
|
||||
(let ((argument (car arguments)))
|
||||
(if allow-duplicates
|
||||
(unless (member argument allowed-arguments :test #'eq)
|
||||
(error "Undefined nonterminal argument ~S" argument))
|
||||
(progn
|
||||
(unless (gethash argument (grammar-parametrization-argument-attributes grammar-parametrization))
|
||||
(error "Undeclared nonterminal argument ~S" argument))
|
||||
(when (member argument (cdr arguments) :test #'eq)
|
||||
(error "Duplicate nonterminal argument ~S" argument))))))
|
||||
arguments)
|
||||
(values (make-generic-nonterminal symbol parameters) arguments)))
|
||||
(values grammar-symbol-source nil)))
|
||||
|
||||
|
||||
; Call f on each possible binding permutation of the given arguments concatenated with the bindings in
|
||||
; bound-argument-alist. f takes one argument, an association list that maps arguments to attributes.
|
||||
(defun grammar-parametrization-each-permutation (grammar-parametrization f arguments &optional bound-argument-alist)
|
||||
(if arguments
|
||||
(let ((argument (car arguments))
|
||||
(rest-arguments (cdr arguments)))
|
||||
(dolist (attribute (grammar-parametrization-lookup-argument grammar-parametrization argument))
|
||||
(grammar-parametrization-each-permutation grammar-parametrization f rest-arguments (acons argument attribute bound-argument-alist))))
|
||||
(funcall f bound-argument-alist)))
|
||||
|
||||
|
||||
; If general-grammar-symbol is a generic-nonterminal, return one possible binding permutation of its arguments;
|
||||
; otherwise return nil.
|
||||
(defun nonterminal-sample-bound-argument-alist (grammar-parametrization general-grammar-symbol)
|
||||
(when (generic-nonterminal? general-grammar-symbol)
|
||||
(grammar-parametrization-each-permutation
|
||||
grammar-parametrization
|
||||
#'(lambda (bound-argument-alist) (return-from nonterminal-sample-bound-argument-alist bound-argument-alist))
|
||||
(general-grammar-symbol-arguments general-grammar-symbol))))
|
||||
|
||||
|
||||
; If the grammar symbol is a generic nonterminal, convert it into an attributed nonterminal
|
||||
; by instantiating its arguments with the corresponding attributes from the bound-argument-alist.
|
||||
; If the grammar symbol is already an attributed or plain nonterminal, return it unchanged.
|
||||
(defun instantiate-general-grammar-symbol (bound-argument-alist general-grammar-symbol)
|
||||
(if (generic-nonterminal? general-grammar-symbol)
|
||||
(make-attributed-nonterminal
|
||||
(generic-nonterminal-symbol general-grammar-symbol)
|
||||
(mapcar #'(lambda (parameter)
|
||||
(if (nonterminal-argument? parameter)
|
||||
(let ((binding (assoc parameter bound-argument-alist :test #'eq)))
|
||||
(if binding
|
||||
(cdr binding)
|
||||
(error "Unbound nonterminal argument ~S" parameter)))
|
||||
parameter))
|
||||
(generic-nonterminal-parameters general-grammar-symbol)))
|
||||
(assert-type general-grammar-symbol grammar-symbol)))
|
||||
|
||||
|
||||
; If the grammar symbol is a generic nonterminal parametrized on argument, substitute
|
||||
; attribute for argument in it and return the modified grammar symbol. Otherwise, return it unchanged.
|
||||
(defun general-grammar-symbol-substitute (attribute argument general-grammar-symbol)
|
||||
(assert-type attribute nonterminal-attribute)
|
||||
(assert-type argument nonterminal-argument)
|
||||
(if (and (generic-nonterminal? general-grammar-symbol)
|
||||
(member argument (generic-nonterminal-parameters general-grammar-symbol) :test #'eq))
|
||||
(make-generic-nonterminal
|
||||
(generic-nonterminal-symbol general-grammar-symbol)
|
||||
(substitute attribute argument (generic-nonterminal-parameters general-grammar-symbol) :test #'eq))
|
||||
(assert-type general-grammar-symbol general-grammar-symbol)))
|
||||
|
||||
|
||||
; If the general grammar symbol is a generic nonterminal, return a list of all possible attributed nonterminals
|
||||
; that can be instantiated from it; otherwise, return a one-element list containing the given general grammar symbol.
|
||||
(defun general-grammar-symbol-instances (grammar-parametrization general-grammar-symbol)
|
||||
(if (generic-nonterminal? general-grammar-symbol)
|
||||
(let ((instances nil))
|
||||
(grammar-parametrization-each-permutation
|
||||
grammar-parametrization
|
||||
#'(lambda (bound-argument-alist)
|
||||
(push (instantiate-general-grammar-symbol bound-argument-alist general-grammar-symbol) instances))
|
||||
(general-grammar-symbol-arguments general-grammar-symbol))
|
||||
(nreverse instances))
|
||||
(list (assert-type general-grammar-symbol grammar-symbol))))
|
||||
|
||||
|
||||
; Return true if grammar-symbol can be obtained by calling instantiate-general-grammar-symbol on
|
||||
; general-grammar-symbol.
|
||||
(defun general-nonterminal-is-instance? (grammar-parametrization general-grammar-symbol grammar-symbol)
|
||||
(or (grammar-symbol-= general-grammar-symbol grammar-symbol)
|
||||
(and (generic-nonterminal? general-grammar-symbol)
|
||||
(attributed-nonterminal? grammar-symbol)
|
||||
(let ((parameters (generic-nonterminal-parameters general-grammar-symbol))
|
||||
(attributes (attributed-nonterminal-attributes grammar-symbol)))
|
||||
(and (= (length parameters) (length attributes))
|
||||
(every #'(lambda (parameter attribute)
|
||||
(or (eq parameter attribute)
|
||||
(and (nonterminal-argument? parameter)
|
||||
(member attribute (grammar-parametrization-lookup-argument grammar-parametrization parameter) :test #'eq))))
|
||||
parameters
|
||||
attributes))))))
|
||||
|
|
@ -0,0 +1,531 @@
|
|||
;;; The contents of this file are subject to the Netscape Public License
|
||||
;;; Version 1.0 (the "NPL"); you may not use this file except in
|
||||
;;; compliance with the NPL. You may obtain a copy of the NPL at
|
||||
;;; http://www.mozilla.org/NPL/
|
||||
;;;
|
||||
;;; Software distributed under the NPL is distributed on an "AS IS" basis,
|
||||
;;; WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
|
||||
;;; for the specific language governing rights and limitations under the
|
||||
;;; NPL.
|
||||
;;;
|
||||
;;; The Initial Developer of this code under the NPL is Netscape
|
||||
;;; Communications Corporation. Portions created by Netscape are
|
||||
;;; Copyright (C) 1999 Netscape Communications Corporation. All Rights
|
||||
;;; Reserved.
|
||||
|
||||
;;;
|
||||
;;; HTML output generator
|
||||
;;;
|
||||
;;; Waldemar Horwat (waldemar@netscape.com)
|
||||
;;;
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; ELEMENTS
|
||||
|
||||
(defstruct (html-element (:constructor make-html-element (name self-closing indent
|
||||
newlines-before newlines-begin newlines-end newlines-after))
|
||||
(:predicate html-element?))
|
||||
(name nil :type symbol :read-only t) ;Name of the tag
|
||||
(self-closing nil :type bool :read-only t) ;True if the closing tag should be omitted
|
||||
(indent nil :type integer :read-only t) ;Number of spaces by which to indent this tag's contents in HTML source
|
||||
(newlines-before nil :type integer :read-only t) ;Number of HTML source newlines preceding the opening tag
|
||||
(newlines-begin nil :type integer :read-only t) ;Number of HTML source newlines immediately following the opening tag
|
||||
(newlines-end nil :type integer :read-only t) ;Number of HTML source newlines immediately preceding the closing tag
|
||||
(newlines-after nil :type integer :read-only t)) ;Number of HTML source newlines following the closing tag
|
||||
|
||||
|
||||
; Define symbol to refer to the given html-element.
|
||||
(defun define-html (symbol newlines-before newlines-begin newlines-end newlines-after &key self-closing (indent 0))
|
||||
(setf (get symbol 'html-element) (make-html-element symbol self-closing indent
|
||||
newlines-before newlines-begin newlines-end newlines-after)))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; ELEMENT DEFINITIONS
|
||||
|
||||
(define-html 'a 0 0 0 0)
|
||||
(define-html 'b 0 0 0 0)
|
||||
(define-html 'blockquote 1 0 0 1 :indent 2)
|
||||
(define-html 'body 1 1 1 1)
|
||||
(define-html 'br 0 0 0 1 :self-closing t)
|
||||
(define-html 'code 0 0 0 0)
|
||||
(define-html 'dd 1 0 0 1 :indent 2)
|
||||
(define-html 'del 0 0 0 0)
|
||||
(define-html 'div 1 0 0 1 :indent 2)
|
||||
(define-html 'dl 1 0 0 2 :indent 2)
|
||||
(define-html 'dt 1 0 0 1 :indent 2)
|
||||
(define-html 'em 0 0 0 0)
|
||||
(define-html 'h1 1 0 0 2 :indent 2)
|
||||
(define-html 'h2 1 0 0 2 :indent 2)
|
||||
(define-html 'h3 1 0 0 2 :indent 2)
|
||||
(define-html 'h4 1 0 0 2 :indent 2)
|
||||
(define-html 'h5 1 0 0 2 :indent 2)
|
||||
(define-html 'h6 1 0 0 2 :indent 2)
|
||||
(define-html 'head 1 1 1 2)
|
||||
(define-html 'hr 1 0 0 1 :self-closing t)
|
||||
(define-html 'html 0 1 1 1)
|
||||
(define-html 'i 0 0 0 0)
|
||||
(define-html 'li 1 0 0 1 :indent 2)
|
||||
(define-html 'link 1 0 0 1 :self-closing t)
|
||||
(define-html 'ol 1 1 1 2 :indent 2)
|
||||
(define-html 'p 1 0 0 2)
|
||||
(define-html 'span 0 0 0 0)
|
||||
(define-html 'strong 0 0 0 0)
|
||||
(define-html 'sub 0 0 0 0)
|
||||
(define-html 'sup 0 0 0 0)
|
||||
(define-html 'table 1 1 1 2)
|
||||
(define-html 'td 1 0 0 1 :indent 2)
|
||||
(define-html 'th 1 0 0 1 :indent 2)
|
||||
(define-html 'title 1 0 0 1)
|
||||
(define-html 'tr 1 0 0 1 :indent 2)
|
||||
(define-html 'u 0 0 0 0)
|
||||
(define-html 'ul 1 1 1 2 :indent 2)
|
||||
(define-html 'var 0 0 0 0)
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; ENTITIES
|
||||
|
||||
(defvar *html-entities-list*
|
||||
'((#\& . "amp")
|
||||
(#\" . "quot")
|
||||
(#\< . "lt")
|
||||
(#\> . "gt")
|
||||
(nbsp . "nbsp")))
|
||||
|
||||
(defvar *html-entities-hash* (make-hash-table))
|
||||
|
||||
(dolist (entity-binding *html-entities-list*)
|
||||
(setf (gethash (first entity-binding) *html-entities-hash*) (rest entity-binding)))
|
||||
|
||||
|
||||
; Return a freshly consed list of <html-source> that represent the characters in the string except that
|
||||
; '&', '<', and '>' are replaced by their entities and spaces are replaced by the entity
|
||||
; given by the space parameter (which should be either 'space or 'nbsp).
|
||||
(defun escape-html-characters (string space)
|
||||
(let ((html-sources nil))
|
||||
(labels
|
||||
((escape-remainder (start)
|
||||
(let ((i (position-if #'(lambda (char) (member char '(#\& #\< #\> #\space))) string :start start)))
|
||||
(if i
|
||||
(let ((char (char string i)))
|
||||
(unless (= i start)
|
||||
(push (subseq string start i) html-sources))
|
||||
(push (if (eql char #\space) space char) html-sources)
|
||||
(escape-remainder (1+ i)))
|
||||
(push (if (zerop start) string (subseq string start)) html-sources)))))
|
||||
(unless (zerop (length string))
|
||||
(escape-remainder 0))
|
||||
(nreverse html-sources))))
|
||||
|
||||
|
||||
; Escape all content strings in the html-source, while interpreting :nowrap pseudo-tags.
|
||||
; Return a freshly consed list of html-sources.
|
||||
(defun escape-html-source (html-source space)
|
||||
(cond
|
||||
((stringp html-source)
|
||||
(escape-html-characters html-source space))
|
||||
((or (characterp html-source) (symbolp html-source) (integerp html-source))
|
||||
(list html-source))
|
||||
((consp html-source)
|
||||
(let ((tag (first html-source))
|
||||
(contents (rest html-source)))
|
||||
(if (eq tag ':nowrap)
|
||||
(mapcan #'(lambda (html-source) (escape-html-source html-source 'nbsp)) contents)
|
||||
(list (cons tag
|
||||
(mapcan #'(lambda (html-source) (escape-html-source html-source space)) contents))))))
|
||||
(t (error "Bad html-source: ~S" html-source))))
|
||||
|
||||
|
||||
; Escape all content strings in the html-source, while interpreting :nowrap pseudo-tags.
|
||||
(defun escape-html (html-source)
|
||||
(let ((results (escape-html-source html-source 'space)))
|
||||
(assert-true (= (length results) 1))
|
||||
(first results)))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; HTML WRITER
|
||||
|
||||
;; <html-source> has one of the following formats:
|
||||
;; <string> ;String to be printed literally
|
||||
;; <symbol> ;Named entity
|
||||
;; <integer> ;Numbered entity
|
||||
;; space ;Space or newline
|
||||
;; (<tag> <html-source> ... <html-source>) ;Tag and its contents
|
||||
;; ((:nest <tag> ... <tag>) <html-source> ... <html-source>) ;Equivalent to (<tag> (... (<tag> <html-source> ... <html-source>)))
|
||||
;;
|
||||
;; <tag> has one of the following formats:
|
||||
;; <symbol> ;Tag with no attributes
|
||||
;; (<symbol> <attribute> ... <attribute>) ;Tag with attributes
|
||||
;; :nowrap ;Pseudo-tag indicating that spaces in contents should be non-breaking
|
||||
;;
|
||||
;; <attribute> has one of the following formats:
|
||||
;; (<symbol> <string>) ;Attribute name and value
|
||||
;; (<symbol>) ;Attribute name with omitted value
|
||||
|
||||
|
||||
(defparameter *html-right-margin* 100)
|
||||
|
||||
(defvar *current-html-pos*) ;Number of characters written to the current line of the stream; nil if *current-html-newlines* is nonzero
|
||||
(defvar *current-html-pending*) ;String following a space or newline pending to be printed on the current line or nil if none
|
||||
(defvar *current-html-indent*) ;Indent to use for emit-html-newlines-and-indent calls
|
||||
(defvar *current-html-newlines*) ;Number of consecutive newlines just written to the stream; zero if last character wasn't a newline
|
||||
|
||||
|
||||
; Flush *current-html-pending* onto the stream.
|
||||
(defun flush-current-html-pending (stream)
|
||||
(when *current-html-pending*
|
||||
(unless (zerop (length *current-html-pending*))
|
||||
(write-char #\space stream)
|
||||
(write-string *current-html-pending* stream)
|
||||
(incf *current-html-pos* (1+ (length *current-html-pending*))))
|
||||
(setq *current-html-pending* nil)))
|
||||
|
||||
|
||||
; Emit n-newlines onto the stream and indent the next line by *current-html-indent* spaces.
|
||||
(defun emit-html-newlines-and-indent (stream n-newlines)
|
||||
(decf n-newlines *current-html-newlines*)
|
||||
(when (plusp n-newlines)
|
||||
(flush-current-html-pending stream)
|
||||
(dotimes (i n-newlines)
|
||||
(write-char #\newline stream))
|
||||
(incf *current-html-newlines* n-newlines)
|
||||
(setq *current-html-pos* nil)))
|
||||
|
||||
|
||||
; Write the string to the stream, observing *current-html-pending* and *current-html-pos*.
|
||||
(defun write-html-string (stream html-string)
|
||||
(unless (zerop (length html-string))
|
||||
(unless *current-html-pos*
|
||||
(setq *current-html-newlines* 0)
|
||||
(write-string (make-string *current-html-indent* :initial-element #\space) stream)
|
||||
(setq *current-html-pos* *current-html-indent*))
|
||||
(if *current-html-pending*
|
||||
(progn
|
||||
(setq *current-html-pending* (if (zerop (length *current-html-pending*))
|
||||
html-string
|
||||
(concatenate 'string *current-html-pending* html-string)))
|
||||
(when (>= (+ *current-html-pos* (length *current-html-pending*)) *html-right-margin*)
|
||||
(write-char #\newline stream)
|
||||
(write-string *current-html-pending* stream)
|
||||
(setq *current-html-pos* (length *current-html-pending*))
|
||||
(setq *current-html-pending* nil)))
|
||||
(progn
|
||||
(write-string html-string stream)
|
||||
(incf *current-html-pos* (length html-string))))))
|
||||
|
||||
|
||||
; Emit the html tag with the given tag-symbol (name), attributes, and contents.
|
||||
(defun write-html-tag (stream tag-symbol attributes contents)
|
||||
(let ((element (assert-non-null (get tag-symbol 'html-element))))
|
||||
(emit-html-newlines-and-indent stream (html-element-newlines-before element))
|
||||
(write-html-string stream (format nil "<~A" (html-element-name element)))
|
||||
(let ((*current-html-indent* (+ *current-html-indent* (html-element-indent element))))
|
||||
(dolist (attribute attributes)
|
||||
(let ((name (first attribute))
|
||||
(value (second attribute)))
|
||||
(write-html-source stream 'space)
|
||||
(write-html-string stream (string-downcase (symbol-name name)))
|
||||
(when value
|
||||
(write-html-string stream (format nil "=\"~A\"" value)))))
|
||||
(write-html-string stream ">")
|
||||
(emit-html-newlines-and-indent stream (html-element-newlines-begin element))
|
||||
(dolist (html-source contents)
|
||||
(write-html-source stream html-source)))
|
||||
(unless (html-element-self-closing element)
|
||||
(emit-html-newlines-and-indent stream (html-element-newlines-end element))
|
||||
(write-html-string stream (format nil "</~A>" (html-element-name element))))
|
||||
(emit-html-newlines-and-indent stream (html-element-newlines-after element))))
|
||||
|
||||
|
||||
; Write html-source to the character stream.
|
||||
(defun write-html-source (stream html-source)
|
||||
(cond
|
||||
((stringp html-source)
|
||||
(write-html-string stream html-source))
|
||||
((eq html-source 'space)
|
||||
(when (zerop *current-html-newlines*)
|
||||
(flush-current-html-pending stream)
|
||||
(setq *current-html-pending* "")))
|
||||
((or (characterp html-source) (symbolp html-source))
|
||||
(let ((entity-name (gethash html-source *html-entities-hash*)))
|
||||
(cond
|
||||
(entity-name
|
||||
(write-html-string stream (format nil "&~A;" entity-name)))
|
||||
((characterp html-source)
|
||||
(write-html-string stream (string html-source)))
|
||||
(t (error "Bad html-source ~S" html-source)))))
|
||||
((integerp html-source)
|
||||
(assert-true (and (>= html-source 0) (< html-source 65536)))
|
||||
(write-html-string stream (format nil "&#~D;" html-source)))
|
||||
((consp html-source)
|
||||
(let ((tag (first html-source))
|
||||
(contents (rest html-source)))
|
||||
(if (consp tag)
|
||||
(write-html-tag stream (first tag) (rest tag) contents)
|
||||
(write-html-tag stream tag nil contents))))
|
||||
(t (error "Bad html-source: ~S" html-source))))
|
||||
|
||||
|
||||
; Write the top-level html-source to the character stream.
|
||||
(defun write-html (html-source &optional (stream t))
|
||||
(with-standard-io-syntax
|
||||
(let ((*print-readably* nil)
|
||||
(*print-escape* nil)
|
||||
(*print-case* :upcase)
|
||||
(*current-html-pos* nil)
|
||||
(*current-html-pending* nil)
|
||||
(*current-html-indent* 0)
|
||||
(*current-html-newlines* 9999))
|
||||
(write-string "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0 Transitional//EN\" \"http://www.w3.org/TR/REC-html40/loose.dtd\">" stream)
|
||||
(write-char #\newline stream)
|
||||
(write-html-source stream (escape-html html-source)))))
|
||||
|
||||
|
||||
; Write html to the text file with the given name (relative to the
|
||||
; local directory).
|
||||
(defun write-html-to-local-file (filename html)
|
||||
(with-open-file (stream (merge-pathnames filename *semantic-engine-directory*)
|
||||
:direction :output
|
||||
:if-exists :supersede
|
||||
#+mcl :mac-file-creator #+mcl "MOSS")
|
||||
(write-html html stream)))
|
||||
|
||||
|
||||
; Expand the :nest constructs inside html-source.
|
||||
(defun unnest-html-source (html-source)
|
||||
(labels
|
||||
((unnest-tags (tags contents)
|
||||
(assert-true tags)
|
||||
(cons (first tags)
|
||||
(if (endp (rest tags))
|
||||
contents
|
||||
(list (unnest-tags (rest tags) contents))))))
|
||||
(if (consp html-source)
|
||||
(let ((tag (first html-source))
|
||||
(contents (rest html-source)))
|
||||
(if (and (consp tag) (eq (first tag) ':nest))
|
||||
(unnest-html-source (unnest-tags (rest tag) contents))
|
||||
(cons tag (mapcar #'unnest-html-source contents))))
|
||||
html-source)))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; HTML MAPPINGS
|
||||
|
||||
(defparameter *html-definitions*
|
||||
'(((:new-line t) (br))
|
||||
|
||||
;Misc.
|
||||
(:tab2 nbsp nbsp)
|
||||
(:tab3 nbsp nbsp nbsp)
|
||||
|
||||
;Symbols (-10 suffix means 10-point, etc.)
|
||||
((:bullet 1) #x2022)
|
||||
((:minus 1) "-")
|
||||
((:not-equal 1) #x2260)
|
||||
((:less-or-equal 1) #x2264)
|
||||
((:greater-or-equal 1) #x2265)
|
||||
((:infinity 1) #x221E)
|
||||
((:left-single-quote 1) #x2018)
|
||||
((:right-single-quote 1) #x2019)
|
||||
((:left-double-quote 1) #x201C)
|
||||
((:right-double-quote 1) #x201D)
|
||||
((:left-angle-quote 1) #x00AB)
|
||||
((:right-angle-quote 1) #x00BB)
|
||||
((:bottom-10 1) (:symbol #\x5E)) ;#x22A5
|
||||
((:up-arrow-10 1) (:symbol #\xAD)) ;#x2191
|
||||
((:function-arrow-10 2) (:symbol #\xAE)) ;#x2192
|
||||
((:cartesian-product-10 2) #x00D7)
|
||||
((:identical-10 2) (:symbol #\xBA)) ;#x2261
|
||||
((:member-10 2) (:symbol #\xCE)) ;#x2208
|
||||
((:derives-10 2) (:symbol #\xDE)) ;#x21D2
|
||||
((:left-triangle-bracket-10 1) (:symbol #\xE1)) ;#x2329
|
||||
((:right-triangle-bracket-10 1) (:symbol #\xF1)) ;#x232A
|
||||
((:big-plus-10 2) (:symbol #\xA8)) ;#x271A
|
||||
|
||||
((:alpha 1) (:symbol "a"))
|
||||
((:beta 1) (:symbol "b"))
|
||||
((:chi 1) (:symbol "c"))
|
||||
((:delta 1) (:symbol "d"))
|
||||
((:epsilon 1) (:symbol "e"))
|
||||
((:phi 1) (:symbol "f"))
|
||||
((:gamma 1) (:symbol "g"))
|
||||
((:eta 1) (:symbol "h"))
|
||||
((:iota 1) (:symbol "i"))
|
||||
((:kappa 1) (:symbol "k"))
|
||||
((:lambda 1) (:symbol "l"))
|
||||
((:mu 1) (:symbol "m"))
|
||||
((:nu 1) (:symbol "n"))
|
||||
((:omicron 1) (:symbol "o"))
|
||||
((:pi 1) (:symbol "p"))
|
||||
((:theta 1) (:symbol "q"))
|
||||
((:rho 1) (:symbol "r"))
|
||||
((:sigma 1) (:symbol "s"))
|
||||
((:tau 1) (:symbol "t"))
|
||||
((:upsilon 1) (:symbol "u"))
|
||||
((:omega 1) (:symbol "w"))
|
||||
((:xi 1) (:symbol "x"))
|
||||
((:psi 1) (:symbol "y"))
|
||||
((:zeta 1) (:symbol "z"))
|
||||
|
||||
;Block Styles
|
||||
(:body-text p)
|
||||
(:section-heading h2)
|
||||
(:subsection-heading h3)
|
||||
(:grammar-header h4)
|
||||
(:grammar-rule (:nest :nowrap (div (class "grammar-rule"))))
|
||||
(:grammar-lhs (:nest :nowrap (div (class "grammar-lhs"))))
|
||||
(:grammar-lhs-last :grammar-lhs)
|
||||
(:grammar-rhs (:nest :nowrap (div (class "grammar-rhs"))))
|
||||
(:grammar-rhs-last :grammar-rhs)
|
||||
(:grammar-argument (:nest :nowrap (div (class "grammar-argument"))))
|
||||
(:semantics (:nest :nowrap (p (class "semantics"))))
|
||||
(:semantics-next (:nest :nowrap (p (class "semantics-next"))))
|
||||
|
||||
;Inline Styles
|
||||
(:symbol (span (class "symbol")))
|
||||
(:character-literal code)
|
||||
(:character-literal-control (span (class "control")))
|
||||
(:terminal (span (class "terminal")))
|
||||
(:terminal-keyword (code (class "terminal-keyword")))
|
||||
(:nonterminal (var (class "nonterminal")))
|
||||
(:nonterminal-attribute (span (class "nonterminal-attribute")))
|
||||
(:nonterminal-argument (span (class "nonterminal-argument")))
|
||||
(:semantic-keyword (span (class "semantic-keyword")))
|
||||
(:type-expression (span (class "type-expression")))
|
||||
(:type-name (span (class "type-name")))
|
||||
(:field-name (span (class "field-name")))
|
||||
(:global-variable (span (class "global-variable")))
|
||||
(:local-variable (span (class "local-variable")))
|
||||
(:action-name (span (class "action-name")))
|
||||
|
||||
;Specials
|
||||
(:invisible del)
|
||||
((:but-not 6) (b "except"))
|
||||
(:subscript sub)
|
||||
(:superscript sup)
|
||||
(:plain-subscript :subscript)
|
||||
((:action-begin 1) "[")
|
||||
((:action-end 1) "]")
|
||||
((:vector-begin 1) (b "["))
|
||||
((:vector-end 1) (b "]"))
|
||||
((:empty-vector 2) (b "[]"))
|
||||
((:vector-append 2) :big-plus-10)
|
||||
((:tuple-begin 1) (b :left-triangle-bracket-10))
|
||||
((:tuple-end 1) (b :right-triangle-bracket-10))
|
||||
((:unit 4) (:global-variable "unit"))
|
||||
((:true 4) (:global-variable "true"))
|
||||
((:false 5) (:global-variable "false"))
|
||||
))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; HTML STREAMS
|
||||
|
||||
(defstruct (html-stream (:include markup-stream)
|
||||
(:constructor allocate-html-stream (env head tail level logical-position))
|
||||
(:copier nil)
|
||||
(:predicate html-stream?)))
|
||||
|
||||
|
||||
(defmethod print-object ((html-stream html-stream) stream)
|
||||
(print-unreadable-object (html-stream stream :identity t)
|
||||
(write-string "html-stream" stream)))
|
||||
|
||||
|
||||
; Make a new, empty, open html-stream with the given definitions for its markup-env.
|
||||
(defun make-html-stream (markup-env level &optional logical-position)
|
||||
(let ((head (list nil)))
|
||||
(allocate-html-stream markup-env head head level logical-position)))
|
||||
|
||||
|
||||
; Make a new, empty, open, top-level html-stream with the given definitions
|
||||
; for its markup-env.
|
||||
(defun make-top-level-html-stream (html-definitions)
|
||||
(let ((head (list nil))
|
||||
(markup-env (make-markup-env)))
|
||||
(markup-env-define-alist markup-env html-definitions)
|
||||
(allocate-html-stream markup-env head head *markup-stream-top-level* nil)))
|
||||
|
||||
|
||||
; Return the approximate width of the html item; return t if it is a line break.
|
||||
; Also allow html tags as long as they do not contain line breaks.
|
||||
(defmethod markup-group-width ((html-stream html-stream) item)
|
||||
(if (consp item)
|
||||
(reduce #'+ (rest item) :key #'(lambda (subitem) (markup-group-width html-stream subitem)))
|
||||
(markup-width html-stream item)))
|
||||
|
||||
|
||||
; Create a top-level html-stream and call emitter to emit its contents.
|
||||
; emitter takes one argument -- an html-stream to which it should emit paragraphs.
|
||||
; Return the top-level html-stream.
|
||||
(defun depict-html-top-level (emitter title)
|
||||
(let ((html-stream (make-top-level-html-stream *html-definitions*)))
|
||||
(markup-stream-append1 html-stream 'html)
|
||||
(depict-block-style (html-stream 'head)
|
||||
(depict-block-style (html-stream 'title)
|
||||
(markup-stream-append1 html-stream title))
|
||||
(markup-stream-append1 html-stream '((link (rel "stylesheet") (href "styles.css")))))
|
||||
(depict-block-style (html-stream 'body)
|
||||
(funcall emitter html-stream))
|
||||
html-stream))
|
||||
|
||||
|
||||
; Create a top-level html-stream and call emitter to emit its contents.
|
||||
; emitter takes one argument -- an html-stream to which it should emit paragraphs.
|
||||
; Write the resulting html to the text file with the given name (relative to the
|
||||
; local directory).
|
||||
(defun depict-html-to-local-file (filename emitter title)
|
||||
(let ((top-html-stream (depict-html-top-level emitter title)))
|
||||
(write-html-to-local-file filename (markup-stream-output top-html-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 ((html-stream html-stream))
|
||||
(unnest-html-source
|
||||
(markup-env-expand (markup-stream-env html-stream) (markup-stream-unexpanded-output html-stream) '(:nowrap :nest))))
|
||||
|
||||
|
||||
|
||||
(defmethod depict-block-style-f ((html-stream html-stream) block-style emitter)
|
||||
(assert-true (<= (markup-stream-level html-stream) *markup-stream-paragraph-level*))
|
||||
(assert-true (and block-style (symbolp block-style)))
|
||||
(let ((inner-html-stream (make-html-stream (markup-stream-env html-stream) *markup-stream-paragraph-level* nil)))
|
||||
(markup-stream-append1 inner-html-stream block-style)
|
||||
(prog1
|
||||
(funcall emitter inner-html-stream)
|
||||
(markup-stream-append1 html-stream (markup-stream-unexpanded-output inner-html-stream)))))
|
||||
|
||||
|
||||
(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 ((inner-html-stream (make-html-stream (markup-stream-env html-stream) *markup-stream-content-level* (make-logical-position))))
|
||||
(markup-stream-append1 inner-html-stream paragraph-style)
|
||||
(prog1
|
||||
(funcall emitter inner-html-stream)
|
||||
(markup-stream-append1 html-stream (markup-stream-unexpanded-output inner-html-stream)))))
|
||||
|
||||
|
||||
(defmethod depict-char-style-f ((html-stream html-stream) char-style emitter)
|
||||
(assert-true (>= (markup-stream-level html-stream) *markup-stream-content-level*))
|
||||
(assert-true (and char-style (symbolp char-style)))
|
||||
(let ((inner-html-stream (make-html-stream (markup-stream-env html-stream) *markup-stream-content-level* (markup-stream-logical-position html-stream))))
|
||||
(markup-stream-append1 inner-html-stream char-style)
|
||||
(prog1
|
||||
(funcall emitter inner-html-stream)
|
||||
(markup-stream-append1 html-stream (markup-stream-unexpanded-output inner-html-stream)))))
|
||||
|
||||
|
||||
#|
|
||||
(write-html
|
||||
'(html
|
||||
(head
|
||||
(:nowrap (title "This is my title!<>")))
|
||||
((body (atr1 "abc") (beta) (qq))
|
||||
"My page this is " (br) (p))))
|
||||
|#
|
||||
|
|
@ -0,0 +1,361 @@
|
|||
;;; The contents of this file are subject to the Netscape Public License
|
||||
;;; Version 1.0 (the "NPL"); you may not use this file except in
|
||||
;;; compliance with the NPL. You may obtain a copy of the NPL at
|
||||
;;; http://www.mozilla.org/NPL/
|
||||
;;;
|
||||
;;; Software distributed under the NPL is distributed on an "AS IS" basis,
|
||||
;;; WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
|
||||
;;; for the specific language governing rights and limitations under the
|
||||
;;; NPL.
|
||||
;;;
|
||||
;;; The Initial Developer of this code under the NPL is Netscape
|
||||
;;; Communications Corporation. Portions created by Netscape are
|
||||
;;; Copyright (C) 1999 Netscape Communications Corporation. All Rights
|
||||
;;; Reserved.
|
||||
|
||||
;;;
|
||||
;;; Sample JavaScript 1.x grammar
|
||||
;;;
|
||||
;;; Waldemar Horwat (waldemar@netscape.com)
|
||||
;;;
|
||||
|
||||
(declaim (optimize (debug 3)))
|
||||
|
||||
(progn
|
||||
(defparameter *jw*
|
||||
(generate-world
|
||||
"J"
|
||||
'((grammar code-grammar :lr-1 :program)
|
||||
|
||||
(%section "Expressions")
|
||||
|
||||
(%subsection "Primary Expressions")
|
||||
(production :primary-expression (this) primary-expression-this)
|
||||
(production :primary-expression (null) primary-expression-null)
|
||||
(production :primary-expression (true) primary-expression-true)
|
||||
(production :primary-expression (false) primary-expression-false)
|
||||
(production :primary-expression ($number) primary-expression-number)
|
||||
(production :primary-expression ($string) primary-expression-string)
|
||||
(production :primary-expression ($identifier) primary-expression-identifier)
|
||||
(production :primary-expression ($regular-expression) primary-expression-regular-expression)
|
||||
(production :primary-expression (\( :expression \)) primary-expression-parentheses)
|
||||
|
||||
|
||||
(%subsection "Left-Side Expressions")
|
||||
(grammar-argument :chi allow-calls no-calls)
|
||||
(grammar-argument :alpha allow-in no-in)
|
||||
|
||||
(production (:member-expression no-calls) (:primary-expression) member-expression-primary-expression)
|
||||
(production (:member-expression allow-calls) ((:member-expression no-calls) :arguments) call-expression-call-member-expression)
|
||||
(production (:member-expression allow-calls) ((:member-expression allow-calls) :arguments) call-expression-call-call-expression)
|
||||
(production (:member-expression :chi) ((:member-expression :chi) \[ :expression \]) member-expression-array)
|
||||
(production (:member-expression :chi) ((:member-expression :chi) \. $identifier) member-expression-property)
|
||||
(production (:member-expression no-calls) (new (:member-expression no-calls) :arguments) member-expression-new)
|
||||
|
||||
(production :new-expression ((:member-expression no-calls)) new-expression-member-expression)
|
||||
(production :new-expression (new :new-expression) new-expression-new)
|
||||
|
||||
(production :arguments (\( \)) arguments-empty)
|
||||
(production :arguments (\( :argument-list \)) arguments-list)
|
||||
|
||||
(production :argument-list ((:assignment-expression allow-in)) argument-list-one)
|
||||
(production :argument-list (:argument-list \, (:assignment-expression allow-in)) argument-list-more)
|
||||
|
||||
(production :left-side-expression (:new-expression) left-side-expression-new-expression)
|
||||
(production :left-side-expression ((:member-expression allow-calls)) left-side-expression-call-expression)
|
||||
|
||||
|
||||
(%subsection "Postfix Expressions")
|
||||
(production :postfix-expression (:left-side-expression) postfix-expression-left-side-expression)
|
||||
(production :postfix-expression (:left-side-expression ++) postfix-expression-increment)
|
||||
(production :postfix-expression (:left-side-expression --) postfix-expression-decrement)
|
||||
|
||||
|
||||
(%subsection "Unary Operators")
|
||||
(production :unary-expression (:postfix-expression) unary-expression-postfix)
|
||||
(production :unary-expression (delete :left-side-expression) unary-expression-delete)
|
||||
(production :unary-expression (void :unary-expression) unary-expression-void)
|
||||
(production :unary-expression (typeof :unary-expression) unary-expression-typeof)
|
||||
(production :unary-expression (++ :left-side-expression) unary-expression-increment)
|
||||
(production :unary-expression (-- :left-side-expression) unary-expression-decrement)
|
||||
(production :unary-expression (+ :unary-expression) unary-expression-plus)
|
||||
(production :unary-expression (- :unary-expression) unary-expression-minus)
|
||||
(production :unary-expression (~ :unary-expression) unary-expression-bitwise-not)
|
||||
(production :unary-expression (! :unary-expression) unary-expression-logical-not)
|
||||
|
||||
|
||||
(%subsection "Multiplicative Operators")
|
||||
(production :multiplicative-expression (:unary-expression) multiplicative-expression-unary)
|
||||
(production :multiplicative-expression (:multiplicative-expression * :unary-expression) multiplicative-expression-multiply)
|
||||
(production :multiplicative-expression (:multiplicative-expression / :unary-expression) multiplicative-expression-divide)
|
||||
(production :multiplicative-expression (:multiplicative-expression % :unary-expression) multiplicative-expression-remainder)
|
||||
|
||||
|
||||
(%subsection "Additive Operators")
|
||||
(production :additive-expression (:multiplicative-expression) additive-expression-multiplicative)
|
||||
(production :additive-expression (:additive-expression + :multiplicative-expression) additive-expression-add)
|
||||
(production :additive-expression (:additive-expression - :multiplicative-expression) additive-expression-subtract)
|
||||
|
||||
|
||||
(%subsection "Bitwise Shift Operators")
|
||||
(production :shift-expression (:additive-expression) shift-expression-additive)
|
||||
(production :shift-expression (:shift-expression << :additive-expression) shift-expression-left)
|
||||
(production :shift-expression (:shift-expression >> :additive-expression) shift-expression-right-signed)
|
||||
(production :shift-expression (:shift-expression >>> :additive-expression) shift-expression-right-unsigned)
|
||||
|
||||
|
||||
(%subsection "Relational Operators")
|
||||
(production (:relational-expression :alpha) (:shift-expression) relational-expression-shift)
|
||||
(production (:relational-expression :alpha) ((:relational-expression :alpha) < :shift-expression) relational-expression-less)
|
||||
(production (:relational-expression :alpha) ((:relational-expression :alpha) > :shift-expression) relational-expression-greater)
|
||||
(production (:relational-expression :alpha) ((:relational-expression :alpha) <= :shift-expression) relational-expression-less-or-equal)
|
||||
(production (:relational-expression :alpha) ((:relational-expression :alpha) >= :shift-expression) relational-expression-greater-or-equal)
|
||||
(production (:relational-expression :alpha) ((:relational-expression :alpha) instanceof :shift-expression) relational-expression-instanceof)
|
||||
(production (:relational-expression allow-in) ((:relational-expression allow-in) in :shift-expression) relational-expression-in)
|
||||
|
||||
|
||||
(%subsection "Equality Operators")
|
||||
(production (:equality-expression :alpha) ((:relational-expression :alpha)) equality-expression-relational)
|
||||
(production (:equality-expression :alpha) ((:equality-expression :alpha) == (:relational-expression :alpha)) equality-expression-equal)
|
||||
(production (:equality-expression :alpha) ((:equality-expression :alpha) != (:relational-expression :alpha)) equality-expression-not-equal)
|
||||
(production (:equality-expression :alpha) ((:equality-expression :alpha) === (:relational-expression :alpha)) equality-expression-strict-equal)
|
||||
(production (:equality-expression :alpha) ((:equality-expression :alpha) !== (:relational-expression :alpha)) equality-expression-strict-not-equal)
|
||||
|
||||
|
||||
(%subsection "Binary Bitwise Operators")
|
||||
(production (:bitwise-and-expression :alpha) ((:equality-expression :alpha)) bitwise-and-expression-equality)
|
||||
(production (:bitwise-and-expression :alpha) ((:bitwise-and-expression :alpha) & (:equality-expression :alpha)) bitwise-and-expression-and)
|
||||
|
||||
(production (:bitwise-xor-expression :alpha) ((:bitwise-and-expression :alpha)) bitwise-xor-expression-bitwise-and)
|
||||
(production (:bitwise-xor-expression :alpha) ((:bitwise-xor-expression :alpha) ^ (:bitwise-and-expression :alpha)) bitwise-xor-expression-xor)
|
||||
|
||||
(production (:bitwise-or-expression :alpha) ((:bitwise-xor-expression :alpha)) bitwise-or-expression-bitwise-xor)
|
||||
(production (:bitwise-or-expression :alpha) ((:bitwise-or-expression :alpha) \| (:bitwise-xor-expression :alpha)) bitwise-or-expression-or)
|
||||
|
||||
|
||||
(%subsection "Binary Logical Operators")
|
||||
(production (:logical-and-expression :alpha) ((:bitwise-or-expression :alpha)) logical-and-expression-bitwise-or)
|
||||
(production (:logical-and-expression :alpha) ((:logical-and-expression :alpha) && (:bitwise-or-expression :alpha)) logical-and-expression-and)
|
||||
|
||||
(production (:logical-or-expression :alpha) ((:logical-and-expression :alpha)) logical-or-expression-logical-and)
|
||||
(production (:logical-or-expression :alpha) ((:logical-or-expression :alpha) \|\| (:logical-and-expression :alpha)) logical-or-expression-or)
|
||||
|
||||
|
||||
(%subsection "Conditional Operator")
|
||||
(production (:conditional-expression :alpha) ((:logical-or-expression :alpha)) conditional-expression-logical-or)
|
||||
(production (:conditional-expression :alpha) ((:logical-or-expression :alpha) ? (:assignment-expression :alpha) \: (:assignment-expression :alpha)) conditional-expression-conditional)
|
||||
|
||||
|
||||
(%subsection "Assignment Operators")
|
||||
(production (:assignment-expression :alpha) ((:conditional-expression :alpha)) assignment-expression-conditional)
|
||||
(production (:assignment-expression :alpha) (:left-side-expression = (:assignment-expression :alpha)) assignment-expression-assignment)
|
||||
(production (:assignment-expression :alpha) (:left-side-expression :compound-assignment (:assignment-expression :alpha)) assignment-expression-compound)
|
||||
|
||||
(production :compound-assignment (*=) compound-assignment-multiply)
|
||||
(production :compound-assignment (/=) compound-assignment-divide)
|
||||
(production :compound-assignment (%=) compound-assignment-remainder)
|
||||
(production :compound-assignment (+=) compound-assignment-add)
|
||||
(production :compound-assignment (-=) compound-assignment-subtract)
|
||||
|
||||
|
||||
(%subsection "Expressions")
|
||||
(production (:comma-expression :alpha) ((:assignment-expression :alpha)) comma-expression-assignment)
|
||||
|
||||
(production :expression ((:comma-expression allow-in)) expression-comma-expression)
|
||||
|
||||
(production :optional-expression (:expression) optional-expression-expression)
|
||||
(production :optional-expression () optional-expression-empty)
|
||||
|
||||
|
||||
(%section "Statements")
|
||||
|
||||
(grammar-argument :omega
|
||||
abbrev ;optional semicolon
|
||||
abbrev-non-empty ;optional semicolon as long as statement isn't empty
|
||||
abbrev-no-short-if ;optional semicolon, but statement must not end with an if without an else
|
||||
full) ;semicolon required at the end
|
||||
|
||||
(production (:statement :omega) (:blocklike-statement) statement-blocklike-statement)
|
||||
(production (:statement :omega) (:unterminated-statement \;) statement-unterminated-statement)
|
||||
(production (:statement :omega) ((:nonuniform-statement :omega)) statement-nonuniform-statement)
|
||||
(production (:statement :omega) ((:if-statement :omega)) statement-if-statement)
|
||||
(production (:statement :omega) ((:while-statement :omega)) statement-while-statement)
|
||||
(production (:statement :omega) ((:for-statement :omega)) statement-for-statement)
|
||||
(production (:statement :omega) ((:labeled-statement :omega)) statement-labeled-statement)
|
||||
|
||||
;Statements that differ depending on omega
|
||||
(production (:nonuniform-statement :omega) (:empty-statement \;) nonuniform-statement-empty-statement)
|
||||
(production (:nonuniform-statement abbrev) (:empty-statement) nonuniform-statement-empty-statement-abbrev)
|
||||
(production (:nonuniform-statement abbrev) (:unterminated-statement) nonuniform-statement-unterminated-statement-abbrev)
|
||||
(production (:nonuniform-statement abbrev-non-empty) (:unterminated-statement) nonuniform-statement-unterminated-statement-abbrev-non-empty)
|
||||
(production (:nonuniform-statement abbrev-no-short-if) (:unterminated-statement) nonuniform-statement-unterminated-statement-abbrev-no-short-if)
|
||||
(production (:nonuniform-statement abbrev-no-short-if) (:empty-statement) nonuniform-statement-empty-statement-abbrev-no-short-if)
|
||||
|
||||
;Statements that always end with a '}'
|
||||
(production :blocklike-statement (:block) blocklike-statement-block)
|
||||
(production :blocklike-statement (:switch-statement) blocklike-statement-switch-statement)
|
||||
(production :blocklike-statement (:try-statement) blocklike-statement-try-statement)
|
||||
|
||||
;Statements that must be followed by a semicolon unless followed by a '}', 'else', or 'while' in a do-while
|
||||
(production :unterminated-statement (:variable-statement) unterminated-statement-variable-statement)
|
||||
(production :unterminated-statement (:expression-statement) unterminated-statement-expression-statement)
|
||||
(production :unterminated-statement (:do-statement) unterminated-statement-do-statement)
|
||||
(production :unterminated-statement (:continue-statement) unterminated-statement-continue-statement)
|
||||
(production :unterminated-statement (:break-statement) unterminated-statement-break-statement)
|
||||
(production :unterminated-statement (:return-statement) unterminated-statement-return-statement)
|
||||
(production :unterminated-statement (:throw-statement) unterminated-statement-throw-statement)
|
||||
|
||||
|
||||
(%subsection "Block")
|
||||
(production :block ({ :block-statements }) block-block-statements)
|
||||
|
||||
(production :block-statements ((:statement abbrev)) block-statements-one)
|
||||
(production :block-statements (:block-statements-prefix (:statement abbrev-non-empty)) block-statements-more)
|
||||
|
||||
(production :block-statements-prefix ((:statement full)) block-statements-prefix-one)
|
||||
(production :block-statements-prefix (:block-statements-prefix (:statement full)) block-statements-prefix-more)
|
||||
|
||||
|
||||
(%subsection "Variable Statement")
|
||||
(production :variable-statement (var (:variable-declaration-list allow-in)) variable-statement-declaration)
|
||||
|
||||
(production (:variable-declaration-list :alpha) ((:variable-declaration :alpha)) variable-declaration-list-one)
|
||||
(production (:variable-declaration-list :alpha) ((:variable-declaration-list :alpha) \, (:variable-declaration :alpha)) variable-declaration-list-more)
|
||||
|
||||
(production (:variable-declaration :alpha) ($identifier) variable-declaration-identifier)
|
||||
(production (:variable-declaration :alpha) ($identifier = (:assignment-expression :alpha)) variable-declaration-initializer)
|
||||
|
||||
|
||||
(%subsection "Empty Statement")
|
||||
(production :empty-statement () empty-statement-empty)
|
||||
|
||||
|
||||
(%subsection "Expression Statement")
|
||||
(production :expression-statement (:expression) expression-statement-expression)
|
||||
|
||||
|
||||
(%subsection "If Statement")
|
||||
(production (:if-statement abbrev) (if \( :expression \) (:statement abbrev)) if-statement-if-then-abbrev)
|
||||
(production (:if-statement abbrev-non-empty) (if \( :expression \) (:statement abbrev-non-empty)) if-statement-if-then-abbrev-non-empty)
|
||||
(production (:if-statement full) (if \( :expression \) (:statement full)) if-statement-if-then-full)
|
||||
(production (:if-statement :omega) (if \( :expression \) (:statement abbrev-no-short-if)
|
||||
else (:statement :omega)) if-statement-if-then-else)
|
||||
|
||||
|
||||
(%subsection "Do-While Statement")
|
||||
(production :do-statement (do (:statement abbrev-non-empty) while \( :expression \)) do-statement-do-while)
|
||||
|
||||
|
||||
(%subsection "While Statement")
|
||||
(production (:while-statement :omega) (while \( :expression \) (:statement :omega)) while-statement-while)
|
||||
|
||||
|
||||
(%subsection "For Statements")
|
||||
(production (:for-statement :omega) (for \( :for-initializer \; :optional-expression \; :optional-expression \)
|
||||
(:statement :omega)) for-statement-c-style)
|
||||
(production (:for-statement :omega) (for \( :for-in-binding in :expression \) (:statement :omega)) for-statement-in)
|
||||
|
||||
(production :for-initializer () for-initializer-empty)
|
||||
(production :for-initializer ((:comma-expression no-in)) for-initializer-expression)
|
||||
(production :for-initializer (var (:variable-declaration-list no-in)) for-initializer-variable-declaration)
|
||||
|
||||
(production :for-in-binding (:left-side-expression) for-in-binding-expression)
|
||||
(production :for-in-binding (var (:variable-declaration no-in)) for-in-binding-variable-declaration)
|
||||
|
||||
|
||||
(%subsection "Continue and Break Statements")
|
||||
(production :continue-statement (continue :optional-label) continue-statement-optional-label)
|
||||
|
||||
(production :break-statement (break :optional-label) break-statement-optional-label)
|
||||
|
||||
(production :optional-label () optional-label-default)
|
||||
(production :optional-label ($identifier) optional-label-identifier)
|
||||
|
||||
|
||||
(%subsection "Labeled Statements")
|
||||
(production (:labeled-statement :omega) ($identifier \: (:statement :omega)) labeled-statement-label)
|
||||
|
||||
|
||||
(%subsection "Return Statement")
|
||||
(production :return-statement (return :optional-expression) return-statement-optional-expression)
|
||||
|
||||
|
||||
(%subsection "Switch Statement")
|
||||
(production :switch-statement (switch \( :expression \) { }) switch-statement-empty)
|
||||
(production :switch-statement (switch \( :expression \) { :case-groups :last-case-group }) switch-statement-cases)
|
||||
|
||||
(production :case-groups () case-groups-empty)
|
||||
(production :case-groups (:case-groups :case-group) case-groups-more)
|
||||
|
||||
(production :case-group (:case-guards :block-statements-prefix) case-group-block-statements-prefix)
|
||||
|
||||
(production :last-case-group (:case-guards :block-statements) last-case-group-block-statements)
|
||||
|
||||
(production :case-guards (:case-guard) case-guards-one)
|
||||
(production :case-guards (:case-guards :case-guard) case-guards-more)
|
||||
|
||||
(production :case-guard (case :expression \:) case-guard-case)
|
||||
(production :case-guard (default \:) case-guard-default)
|
||||
|
||||
|
||||
(%subsection "Throw Statement")
|
||||
(production :throw-statement (throw :expression) throw-statement-throw)
|
||||
|
||||
|
||||
(%subsection "Try Statement")
|
||||
(production :try-statement (try :block :catch-clauses) try-statement-catch-clauses)
|
||||
(production :try-statement (try :block :finally-clause) try-statement-finally-clause)
|
||||
(production :try-statement (try :block :catch-clauses :finally-clause) try-statement-catch-clauses-finally-clause)
|
||||
|
||||
(production :catch-clauses (:catch-clause) catch-clauses-one)
|
||||
(production :catch-clauses (:catch-clauses :catch-clause) catch-clauses-more)
|
||||
|
||||
(production :catch-clause (catch \( $identifier \) :block) catch-clause-block)
|
||||
|
||||
(production :finally-clause (finally :block) finally-clause-block)
|
||||
|
||||
|
||||
(%section "Functions")
|
||||
|
||||
(production :function-declaration (function $identifier \( :formal-parameters \) { :function-statements }) function-declaration-statements)
|
||||
|
||||
(production :formal-parameters () formal-parameters-none)
|
||||
(production :formal-parameters (:formal-parameters-prefix) formal-parameters-some)
|
||||
|
||||
(production :formal-parameters-prefix ($identifier) formal-parameters-prefix-one)
|
||||
(production :formal-parameters-prefix (:formal-parameters-prefix \, $identifier) formal-parameters-prefix-more)
|
||||
|
||||
(production :function-statements ((:function-statement abbrev)) function-statements-one)
|
||||
(production :function-statements (:function-statements-prefix (:function-statement abbrev-non-empty)) function-statements-more)
|
||||
|
||||
(production :function-statements-prefix ((:function-statement full)) function-statements-prefix-one)
|
||||
(production :function-statements-prefix (:function-statements-prefix (:function-statement full)) function-statements-prefix-more)
|
||||
|
||||
(production (:function-statement :omega) ((:statement :omega)) function-statement-statement)
|
||||
(production (:function-statement :omega) (:function-declaration) function-statement-function-declaration)
|
||||
|
||||
|
||||
(%section "Programs")
|
||||
|
||||
(production :program (:function-statements) program)
|
||||
)))
|
||||
|
||||
(defparameter *jg* (world-grammar *jw* 'code-grammar)))
|
||||
|
||||
|
||||
#|
|
||||
(let ((*visible-modes* nil))
|
||||
(depict-rtf-to-local-file
|
||||
"JS14.rtf"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *jw*))))
|
||||
|
||||
(let ((*visible-modes* nil))
|
||||
(depict-html-to-local-file
|
||||
"JS14.html"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *jw*))
|
||||
"JavaScript 2.0 Grammar"))
|
||||
|
||||
(with-local-output (s "JS14.txt") (print-grammar *jg* s))
|
||||
|#
|
||||
|
|
@ -0,0 +1,624 @@
|
|||
;;; The contents of this file are subject to the Netscape Public License
|
||||
;;; Version 1.0 (the "NPL"); you may not use this file except in
|
||||
;;; compliance with the NPL. You may obtain a copy of the NPL at
|
||||
;;; http://www.mozilla.org/NPL/
|
||||
;;;
|
||||
;;; Software distributed under the NPL is distributed on an "AS IS" basis,
|
||||
;;; WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
|
||||
;;; for the specific language governing rights and limitations under the
|
||||
;;; NPL.
|
||||
;;;
|
||||
;;; The Initial Developer of this code under the NPL is Netscape
|
||||
;;; Communications Corporation. Portions created by Netscape are
|
||||
;;; Copyright (C) 1998 Netscape Communications Corporation. All Rights
|
||||
;;; Reserved.
|
||||
|
||||
;;;
|
||||
;;; Lexer grammar generator
|
||||
;;;
|
||||
;;; Waldemar Horwat (waldemar@netscape.com)
|
||||
;;;
|
||||
|
||||
|
||||
;;; A lexer grammar is an extension of a standard grammar that combines both parsing and combining
|
||||
;;; characters into character classes.
|
||||
;;;
|
||||
;;; A lexer grammar is comprised of the following:
|
||||
;;; a start nonterminal;
|
||||
;;; a list of grammar productions, in which each terminal must be a character;
|
||||
;;; a list of character classes, where each class is a list of:
|
||||
;;; a nonterminal C;
|
||||
;;; an expression <set-expr> that denotes the set of characters in character class C;
|
||||
;;; a list of bindings, each containing:
|
||||
;;; an action name;
|
||||
;;; a lexer-action name;
|
||||
;;; a list of lexer-action bindings, each containing:
|
||||
;;; a lexer-action name;
|
||||
;;; the type of this lexer-action's value;
|
||||
;;; the name of a lisp function (char -> value) that performs the lexer-action on a character.
|
||||
;;;
|
||||
;;; Grammar productions may refer to character classes C as nonterminals.
|
||||
;;;
|
||||
;;; An expression <set-expr> can be any of the following:
|
||||
;;; C The name of a previously defined character class.
|
||||
;;; every The set of all characters
|
||||
;;; (char1 char2 ... charn) The set of characters {char1, char2, ..., charn}
|
||||
;;; (+ <set-expr1> ... <set-exprn>) The set union of <set-expr1>, ..., <set-exprn>,
|
||||
;;; which should be disjoint.
|
||||
;;; (++ <set-expr1> ... <set-exprn>) Same as +, but printed on separate lines.
|
||||
;;; (- <set-expr1> <set-expr2>) The set of characters in <set-expr1> but not <set-expr2>;
|
||||
;;; <set-expr2> should be a subset of <set-expr1>.
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; SETS OF CHARACTERS
|
||||
|
||||
;;; A character set is represented by an integer.
|
||||
;;; The set may be infinite as long as its complement is finite.
|
||||
;;; Bit n is set if the character with code n is a member of the set.
|
||||
;;; The integer is negative if the set is infinite.
|
||||
|
||||
|
||||
; Print the charset
|
||||
(defun print-charset (charset &optional (stream t))
|
||||
(pprint-logical-block (stream (bitmap-to-ranges charset) :prefix "{" :suffix "}")
|
||||
(pprint-exit-if-list-exhausted)
|
||||
(loop
|
||||
(flet
|
||||
((int-to-char (i)
|
||||
(if (or (eq i :infinity) (= i char-code-limit))
|
||||
:infinity
|
||||
(code-char i))))
|
||||
(let* ((range (pprint-pop))
|
||||
(lo (int-to-char (car range)))
|
||||
(hi (int-to-char (cdr range))))
|
||||
(write (if (eql lo hi) lo (list lo hi)) :stream stream :pretty t)
|
||||
(pprint-exit-if-list-exhausted)
|
||||
(format stream " ~:_"))))))
|
||||
|
||||
|
||||
; Return the character set consisting of the single character char.
|
||||
(declaim (inline char-charset))
|
||||
(defun char-charset (char)
|
||||
(ash 1 (char-code char)))
|
||||
|
||||
|
||||
; Return the character set consisting of adding char to the given charset.
|
||||
(defun charset-add-char (charset char)
|
||||
(let ((i (char-code char)))
|
||||
(if (logbitp i charset)
|
||||
charset
|
||||
(logior charset (ash 1 i)))))
|
||||
|
||||
|
||||
; Return the union of the two character sets, which should be disjoint.
|
||||
(defun charset-union (charset1 charset2)
|
||||
(unless (zerop (logand charset1 charset2))
|
||||
(error "Union of overlapping character sets"))
|
||||
(logior charset1 charset2))
|
||||
|
||||
|
||||
; Return the difference of the two character sets, the second of which should be
|
||||
; a subset of the first.
|
||||
(defun charset-difference (charset1 charset2)
|
||||
(unless (zerop (logandc1 charset1 charset2))
|
||||
(error "Difference of non-subset character sets"))
|
||||
(logandc2 charset1 charset2))
|
||||
|
||||
|
||||
; Return true if the character set is empty.
|
||||
(declaim (inline charset-empty?))
|
||||
(defun charset-empty? (charset)
|
||||
(zerop charset))
|
||||
|
||||
|
||||
; Return true if the character set is infinite.
|
||||
(declaim (inline charset-infinite?))
|
||||
(defun charset-infinite? (charset)
|
||||
(minusp charset))
|
||||
|
||||
|
||||
; If the character set contains exactly one character, return that character;
|
||||
; otherwise, return nil.
|
||||
(defun charset-char (charset)
|
||||
(let ((hi (1- (integer-length charset))))
|
||||
(and (plusp charset) (= charset (ash 1 hi)) (code-char hi))))
|
||||
|
||||
|
||||
; Return the highest character in the character set, which must be finite and nonempty.
|
||||
(declaim (inline charset-highest-char))
|
||||
(defun charset-highest-char (charset)
|
||||
(assert-true (plusp charset))
|
||||
(code-char (1- (integer-length charset))))
|
||||
|
||||
|
||||
; Given a list of charsets, return a list of the largest possible
|
||||
; charsets (called partitions) such that:
|
||||
; for any input charset C and partition P, either P is entirely contained in C or it is disjoint from C;
|
||||
; all partitions are mutually disjoint;
|
||||
; the union of all partitions is the infinite set of all characters.
|
||||
(defun compute-partitions (charsets)
|
||||
(labels
|
||||
((split-partitions (partitions charset)
|
||||
(mapcan #'(lambda (partition)
|
||||
(remove-if #'zerop (list (logand partition charset) (logandc2 partition charset))))
|
||||
partitions))
|
||||
(partition< (partition1 partition2)
|
||||
(cond
|
||||
((minusp partition1) nil)
|
||||
((minusp partition2) t)
|
||||
(t (< partition1 partition2)))))
|
||||
(sort (reduce #'split-partitions charsets :initial-value '(-1))
|
||||
#'partition<)))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; LEXER-ACTIONS
|
||||
|
||||
(defstruct (lexer-action (:constructor make-lexer-action (name number type-expr function-name markup))
|
||||
(:copier nil)
|
||||
(:predicate lexer-action?))
|
||||
(name nil :type identifier :read-only t) ;The action name to use for this lexer-action
|
||||
(number nil :type integer :read-only t) ;Serial number of this lexer-action
|
||||
(type-expr nil :read-only t) ;A type expression that specifies the result type of list function function-name
|
||||
(function-name nil :type identifier :read-only t) ;A lisp function (char -> value) that performs the lexer-action on a character
|
||||
(markup nil :type list :read-only t)) ;Markup template describing this lexer-action; replace '* with the nonterminal
|
||||
|
||||
|
||||
(defun print-lexer-action (lexer-action &optional (stream t))
|
||||
(format stream "~@<~A ~@_~:I: ~<<<~;~W~;>>~:> ~_= ~<<~;#'~W~;>~:>~:>"
|
||||
(lexer-action-name lexer-action)
|
||||
(list (lexer-action-type-expr lexer-action))
|
||||
(list (lexer-action-function-name lexer-action))))
|
||||
|
||||
|
||||
(defun depict-lexer-action (markup-stream lexer-action nonterminal)
|
||||
(dolist (markup-item (lexer-action-markup lexer-action))
|
||||
(if (eq markup-item '*)
|
||||
(depict-general-nonterminal markup-stream nonterminal)
|
||||
(depict-group markup-stream markup-item))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; CHARCLASSES
|
||||
|
||||
(defstruct (charclass (:constructor make-charclass (nonterminal charset-source charset actions))
|
||||
(:predicate charclass?))
|
||||
(nonterminal nil :type nonterminal :read-only t) ;The nonterminal on the left-hand side of this production
|
||||
(charset-source nil :read-only t) ;The source expression for the charset
|
||||
(charset nil :type integer :read-only t) ;The set of characters in this class
|
||||
(actions nil :type list :read-only t)) ;List of (action-name . lexer-action)
|
||||
|
||||
|
||||
; Evaluate a <set-expr> whose syntax is given at the top of this file.
|
||||
; Return the charset.
|
||||
; charclasses-hash is a hash table of nonterminal -> charclass.
|
||||
(defun eval-charset-expr (charclasses-hash expr)
|
||||
(cond
|
||||
((null expr) 0)
|
||||
((eq expr 'every) -1)
|
||||
((symbolp expr)
|
||||
(charclass-charset
|
||||
(or (gethash expr charclasses-hash)
|
||||
(error "Character class ~S not defined" expr))))
|
||||
((consp expr)
|
||||
(labels
|
||||
((recursive-eval (expr)
|
||||
(eval-charset-expr charclasses-hash expr)))
|
||||
(case (car expr)
|
||||
((+ ++) (reduce #'charset-union (cdr expr) :initial-value 0 :key #'recursive-eval))
|
||||
(- (unless (cdr expr)
|
||||
(error "Bad character set expression ~S" expr))
|
||||
(reduce #'charset-difference (cdr expr) :key #'recursive-eval))
|
||||
(t (reduce #'charset-union expr :key #'char-charset)))))
|
||||
(t (error "Bad character set expression ~S" expr))))
|
||||
|
||||
|
||||
(defun print-charclass (charclass &optional (stream t))
|
||||
(pprint-logical-block (stream nil)
|
||||
(format stream "~W -> ~@_~:I" (charclass-nonterminal charclass))
|
||||
(print-charset (charclass-charset charclass) stream)
|
||||
(format stream " ~_")
|
||||
(pprint-fill stream (mapcar #'car (charclass-actions charclass)))))
|
||||
|
||||
|
||||
; Emit markup for the lexer charset expression.
|
||||
(defun depict-charset-source (markup-stream expr)
|
||||
(cond
|
||||
((null expr) (error "Can't emit null charset expression"))
|
||||
((eq expr 'every) (depict-general-nonterminal markup-stream ':any-character))
|
||||
((symbolp expr) (depict-general-nonterminal markup-stream expr))
|
||||
((consp expr)
|
||||
(case (car expr)
|
||||
((+ ++) (depict-list markup-stream #'depict-charset-source (cdr expr) :separator " | "))
|
||||
(- (depict-charset-source markup-stream (second expr))
|
||||
(depict markup-stream " " :but-not " ")
|
||||
(depict-list markup-stream #'depict-charset-source (cddr expr) :separator " | "))
|
||||
(t (depict-list markup-stream #'depict-terminal expr :separator " | "))))
|
||||
(t (error "Bad character set expression ~S" expr))))
|
||||
|
||||
|
||||
; Emit markup paragraphs for the lexer charclass.
|
||||
(defun depict-charclass (markup-stream charclass)
|
||||
(let ((nonterminal (charclass-nonterminal charclass))
|
||||
(expr (charclass-charset-source charclass)))
|
||||
(if (and (consp expr) (eq (car expr) '++))
|
||||
(let* ((subexprs (cdr expr))
|
||||
(length (length subexprs)))
|
||||
(depict-paragraph (markup-stream ':grammar-lhs)
|
||||
(depict-general-nonterminal markup-stream nonterminal)
|
||||
(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))
|
||||
(depict markup-stream " " ':derives-10 " ")
|
||||
(depict-charset-source markup-stream expr)))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; PARTITIONS
|
||||
|
||||
(defstruct (partition (:constructor make-partition (charset lexer-actions))
|
||||
(:predicate partition?))
|
||||
(charset nil :type integer :read-only t) ;The set of characters in this partition
|
||||
(lexer-actions nil :type list :read-only t)) ;List of lexer-actions needed on characters in this partition
|
||||
|
||||
(defconstant *default-partition-name* '$_other_) ;partition-name to use for characters not found in lexer-char-tokens
|
||||
|
||||
|
||||
(defun print-partition (partition-name partition &optional (stream t))
|
||||
(pprint-logical-block (stream nil)
|
||||
(format stream "~W -> ~@_~:I" partition-name)
|
||||
(print-charset (partition-charset partition) stream)
|
||||
(format stream " ~_")
|
||||
(pprint-fill stream (mapcar #'lexer-action-name (partition-lexer-actions partition)))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; LEXER
|
||||
|
||||
|
||||
(defstruct (lexer (:constructor allocate-lexer)
|
||||
(:copier nil)
|
||||
(:predicate lexer?))
|
||||
(lexer-actions nil :type hash-table :read-only t) ;Hash table of lexer-action-name -> lexer-action
|
||||
(charclasses nil :type list :read-only t) ;List of charclasses in the order in which they were given
|
||||
(charclasses-hash nil :type hash-table :read-only t) ;Hash table of nonterminal -> charclass
|
||||
(char-tokens nil :type hash-table :read-only t) ;Hash table of character -> (character or partition-name)
|
||||
(partition-names nil :type list :read-only t) ;List of partition names in the order in which they were created
|
||||
(partitions nil :type hash-table :read-only t) ;Hash table of partition-name -> partition
|
||||
(grammar nil :type (or null grammar)) ;Grammar that accepts exactly one lexer token
|
||||
(metagrammar nil :type (or null metagrammar))) ;Grammar that accepts the longest input sequence that forms a token
|
||||
|
||||
|
||||
; Return a function (character -> terminal) that classifies an input character
|
||||
; as either itself or a partition-name.
|
||||
; If the returned function is called on a non-character, it returns its input unchanged.
|
||||
(defun lexer-classifier (lexer)
|
||||
(let ((char-tokens (lexer-char-tokens lexer)))
|
||||
#'(lambda (char)
|
||||
(if (characterp char)
|
||||
(gethash char char-tokens *default-partition-name*)
|
||||
char))))
|
||||
|
||||
|
||||
; Return the charclass that defines the given lexer nonterminal or nil if none.
|
||||
(defun lexer-charclass (lexer nonterminal)
|
||||
(gethash nonterminal (lexer-charclasses-hash lexer)))
|
||||
|
||||
|
||||
; Return the charset of all characters that appear as terminals in grammar-source.
|
||||
(defun grammar-singletons (grammar-source)
|
||||
(assert-type grammar-source (list (tuple t (list t) identifier)))
|
||||
(let ((singletons 0))
|
||||
(dolist (production-source grammar-source)
|
||||
(dolist (grammar-symbol (second production-source))
|
||||
(when (characterp grammar-symbol)
|
||||
(setq singletons (charset-add-char singletons grammar-symbol)))))
|
||||
singletons))
|
||||
|
||||
|
||||
; Return the list of all lexer-action-names that appear in at least one charclass of which this
|
||||
; partition is a subset.
|
||||
(defun collect-lexer-action-names (charclasses partition)
|
||||
(let ((lexer-action-names nil))
|
||||
(dolist (charclass charclasses)
|
||||
(unless (zerop (logand (charclass-charset charclass) partition))
|
||||
(dolist (action (charclass-actions charclass))
|
||||
(pushnew (cdr action) lexer-action-names))))
|
||||
(sort lexer-action-names #'< :key #'lexer-action-number)))
|
||||
|
||||
|
||||
; Make a lexer structure corresponding to a grammar with the given source.
|
||||
; charclasses-source is a list of character classes, where each class is a list of:
|
||||
; a nonterminal C;
|
||||
; an expression <set-expr> that denotes the set of characters in character class C;
|
||||
; a list of bindings, each containing:
|
||||
; an action name;
|
||||
; a lexer-action name.
|
||||
; lexer-actions-source is a list of lexer-action bindings, each containing:
|
||||
; a lexer-action name;
|
||||
; the type of this lexer-action's value;
|
||||
; the name of a lisp function (char -> value) that performs the lexer-action on a character.
|
||||
; This does not make the lexer's grammar; use make-lexer-and-grammar for that.
|
||||
(defun make-lexer (charclasses-source lexer-actions-source grammar-source)
|
||||
(assert-type charclasses-source (list (tuple nonterminal t (list (tuple identifier identifier)))))
|
||||
(assert-type lexer-actions-source (list (tuple identifier t identifier list)))
|
||||
(let ((lexer-actions (make-hash-table :test #'eq))
|
||||
(charclasses nil)
|
||||
(charclasses-hash (make-hash-table :test *grammar-symbol-=*))
|
||||
(charsets nil)
|
||||
(singletons (grammar-singletons grammar-source)))
|
||||
(let ((lexer-action-number 0))
|
||||
(dolist (lexer-action-source lexer-actions-source)
|
||||
(let ((name (first lexer-action-source))
|
||||
(type-expr (second lexer-action-source))
|
||||
(function (third lexer-action-source))
|
||||
(markup (fourth lexer-action-source)))
|
||||
(when (gethash name lexer-actions)
|
||||
(error "Attempt to redefine lexer action ~S" name))
|
||||
(setf (gethash name lexer-actions)
|
||||
(make-lexer-action name (incf lexer-action-number) type-expr function markup)))))
|
||||
|
||||
(dolist (charclass-source charclasses-source)
|
||||
(let ((nonterminal (first charclass-source))
|
||||
(charset (eval-charset-expr charclasses-hash (ensure-proper-form (second charclass-source))))
|
||||
(actions
|
||||
(mapcar #'(lambda (action-source)
|
||||
(let* ((lexer-action-name (second action-source))
|
||||
(lexer-action (gethash lexer-action-name lexer-actions)))
|
||||
(unless lexer-action
|
||||
(error "Unknown lexer-action ~S" lexer-action-name))
|
||||
(cons (first action-source) lexer-action)))
|
||||
(third charclass-source))))
|
||||
(when (gethash nonterminal charclasses-hash)
|
||||
(error "Attempt to redefine character class ~S" nonterminal))
|
||||
(when (charset-empty? charset)
|
||||
(error "Empty character class ~S" nonterminal))
|
||||
(let ((charclass (make-charclass nonterminal (second charclass-source) charset actions)))
|
||||
(push charclass charclasses)
|
||||
(setf (gethash nonterminal charclasses-hash) charclass)
|
||||
(push charset charsets))))
|
||||
(setq charclasses (nreverse charclasses))
|
||||
(bitmap-each-bit #'(lambda (i) (push (ash 1 i) charsets))
|
||||
singletons)
|
||||
(let ((char-tokens (make-hash-table :test #'eql))
|
||||
(partition-names nil)
|
||||
(partitions (make-hash-table :test #'eq))
|
||||
(current-partition-number 0))
|
||||
(dolist (partition (compute-partitions charsets))
|
||||
(let ((singleton (charset-char partition)))
|
||||
(cond
|
||||
(singleton (setf (gethash singleton char-tokens) singleton))
|
||||
((charset-infinite? partition)
|
||||
(push *default-partition-name* partition-names)
|
||||
(setf (gethash *default-partition-name* partitions)
|
||||
(make-partition partition (collect-lexer-action-names charclasses partition))))
|
||||
(t (let ((token (intern (format nil "$_CHARS~D_" (incf current-partition-number)))))
|
||||
(bitmap-each-bit #'(lambda (i)
|
||||
(setf (gethash (code-char i) char-tokens) token))
|
||||
partition)
|
||||
(push token partition-names)
|
||||
(setf (gethash token partitions)
|
||||
(make-partition partition (collect-lexer-action-names charclasses partition))))))))
|
||||
(allocate-lexer
|
||||
:lexer-actions lexer-actions
|
||||
:charclasses charclasses
|
||||
:charclasses-hash charclasses-hash
|
||||
:char-tokens char-tokens
|
||||
:partition-names (nreverse partition-names)
|
||||
:partitions partitions))))
|
||||
|
||||
|
||||
(defun print-lexer (lexer &optional (stream t))
|
||||
(let* ((lexer-actions (lexer-lexer-actions lexer))
|
||||
(lexer-action-names (sort (hash-table-keys lexer-actions) #'<
|
||||
:key #'(lambda (lexer-action-name)
|
||||
(lexer-action-number (gethash lexer-action-name lexer-actions)))))
|
||||
(charclasses (lexer-charclasses lexer))
|
||||
(partition-names (lexer-partition-names lexer))
|
||||
(partitions (lexer-partitions lexer))
|
||||
(singletons nil))
|
||||
|
||||
(when lexer-action-names
|
||||
(pprint-logical-block (stream lexer-action-names)
|
||||
(format stream "Lexer Actions:~2I")
|
||||
(loop
|
||||
(pprint-newline :mandatory stream)
|
||||
(let ((lexer-action (gethash (pprint-pop) lexer-actions)))
|
||||
(print-lexer-action lexer-action stream))
|
||||
(pprint-exit-if-list-exhausted)))
|
||||
(pprint-newline :mandatory stream)
|
||||
(pprint-newline :mandatory stream))
|
||||
|
||||
(when charclasses
|
||||
(pprint-logical-block (stream charclasses)
|
||||
(format stream "Charclasses:~2I")
|
||||
(loop
|
||||
(pprint-newline :mandatory stream)
|
||||
(let ((charclass (pprint-pop)))
|
||||
(print-charclass charclass stream))
|
||||
(pprint-exit-if-list-exhausted)))
|
||||
(pprint-newline :mandatory stream)
|
||||
(pprint-newline :mandatory stream))
|
||||
|
||||
(when partition-names
|
||||
(pprint-logical-block (stream partition-names)
|
||||
(format stream "Partitions:~2I")
|
||||
(loop
|
||||
(pprint-newline :mandatory stream)
|
||||
(let ((partition-name (pprint-pop)))
|
||||
(print-partition partition-name (gethash partition-name partitions) stream))
|
||||
(pprint-exit-if-list-exhausted)))
|
||||
(pprint-newline :mandatory stream)
|
||||
(pprint-newline :mandatory stream))
|
||||
|
||||
(maphash
|
||||
#'(lambda (char char-or-partition)
|
||||
(if (eql char char-or-partition)
|
||||
(push char singletons)
|
||||
(assert-type char-or-partition identifier)))
|
||||
(lexer-char-tokens lexer))
|
||||
(setq singletons (sort singletons #'char<))
|
||||
(when singletons
|
||||
(format stream "Singletons: ~@_~<~@{~W ~:_~}~:>~:@_~:@_" singletons))))
|
||||
|
||||
|
||||
(defmethod print-object ((lexer lexer) stream)
|
||||
(print-unreadable-object (lexer stream :identity t)
|
||||
(write-string "lexer" stream)))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
|
||||
|
||||
; Return two values:
|
||||
; extra grammar productions that define the character class nonterminals out of characters and tokens;
|
||||
; extra commands that:
|
||||
; define the partitions used in this lexer;
|
||||
; define the actions of these productions.
|
||||
(defun lexer-grammar-and-commands (lexer)
|
||||
(labels
|
||||
((component-partitions (charset partitions)
|
||||
(if (charset-empty? charset)
|
||||
partitions
|
||||
(let* ((partition-name (if (charset-infinite? charset)
|
||||
*default-partition-name*
|
||||
(gethash (charset-highest-char charset) (lexer-char-tokens lexer))))
|
||||
(partition (gethash partition-name (lexer-partitions lexer))))
|
||||
(component-partitions (charset-difference charset (partition-charset partition))
|
||||
(cons partition partitions))))))
|
||||
(let ((productions nil)
|
||||
(commands nil))
|
||||
(dolist (charclass (lexer-charclasses lexer))
|
||||
(let ((nonterminal (charclass-nonterminal charclass))
|
||||
(production-number 0))
|
||||
(dolist (action (charclass-actions charclass))
|
||||
(let ((lexer-action (cdr action)))
|
||||
(push (list 'declare-action (car action) nonterminal (lexer-action-type-expr lexer-action)) commands)))
|
||||
(do ((charset (charclass-charset charclass)))
|
||||
((charset-empty? charset))
|
||||
(let* ((partition-name (if (charset-infinite? charset)
|
||||
*default-partition-name*
|
||||
(gethash (charset-highest-char charset) (lexer-char-tokens lexer))))
|
||||
(partition-charset (if (characterp partition-name)
|
||||
(char-charset partition-name)
|
||||
(partition-charset (gethash partition-name (lexer-partitions lexer)))))
|
||||
(production-name (intern (format nil "~A-~D" nonterminal (incf production-number)))))
|
||||
(push (list nonterminal (list partition-name) production-name) productions)
|
||||
(dolist (action (charclass-actions charclass))
|
||||
(let* ((lexer-action (cdr action))
|
||||
(body (if (characterp partition-name)
|
||||
(let* ((lexer-action-function (lexer-action-function-name lexer-action))
|
||||
(result (funcall lexer-action-function partition-name)))
|
||||
(typecase result
|
||||
(integer result)
|
||||
(character result)
|
||||
((eql nil) 'false)
|
||||
((eql t) 'true)
|
||||
(t (error "Cannot infer the type of ~S's result ~S" lexer-action-function result))))
|
||||
(list (lexer-action-name lexer-action) partition-name))))
|
||||
(push (list 'action (car action) production-name body nil) commands)))
|
||||
(setq charset (charset-difference charset partition-charset))))))
|
||||
|
||||
(let ((partition-commands
|
||||
(mapcan
|
||||
#'(lambda (partition-name)
|
||||
(mapcan #'(lambda (lexer-action)
|
||||
(let ((lexer-action-name (lexer-action-name lexer-action)))
|
||||
(list
|
||||
(list 'declare-action lexer-action-name partition-name (lexer-action-type-expr lexer-action))
|
||||
(list 'terminal-action lexer-action-name partition-name (lexer-action-function-name lexer-action)))))
|
||||
(partition-lexer-actions (gethash partition-name (lexer-partitions lexer)))))
|
||||
(lexer-partition-names lexer))))
|
||||
(values
|
||||
(nreverse productions)
|
||||
(nconc partition-commands (nreverse commands)))))))
|
||||
|
||||
|
||||
; Make a lexer and grammar from the given source.
|
||||
; kind should be either :lalr-1 or :lr-1.
|
||||
; charclasses-source is a list of character classes, and
|
||||
; lexer-actions-source is a list of lexer-action bindings; see make-lexer.
|
||||
; start-symbol is the grammar's start symbol, and grammar-source is its source.
|
||||
; Return two values:
|
||||
; the lexer (including the grammar in its grammar field);
|
||||
; list of extra commands that:
|
||||
; define the partitions used in this lexer;
|
||||
; define the actions of these productions.
|
||||
(defun make-lexer-and-grammar (kind charclasses-source lexer-actions-source parametrization start-symbol grammar-source)
|
||||
(let ((lexer (make-lexer charclasses-source lexer-actions-source grammar-source)))
|
||||
(multiple-value-bind (extra-grammar-source extra-commands) (lexer-grammar-and-commands lexer)
|
||||
(let ((grammar (make-and-compile-grammar kind parametrization start-symbol (append extra-grammar-source grammar-source))))
|
||||
(setf (lexer-grammar lexer) grammar)
|
||||
(values lexer extra-commands)))))
|
||||
|
||||
|
||||
; Parse the input string to produce a list of action results.
|
||||
; If trace is:
|
||||
; nil, don't print trace information
|
||||
; :code, print trace information, including action code
|
||||
; other print trace information
|
||||
; Return two values:
|
||||
; the list of action results;
|
||||
; the list of action results' types.
|
||||
(defun lexer-parse (lexer string &key trace)
|
||||
(let ((in (coerce string 'list)))
|
||||
(action-parse (lexer-grammar lexer) (lexer-classifier lexer) in :trace trace)))
|
||||
|
||||
|
||||
; Same as lexer-parse except that also print the action results nicely.
|
||||
(defun lexer-pparse (lexer string &key (stream t) trace)
|
||||
(multiple-value-bind (results types) (lexer-parse lexer string :trace trace)
|
||||
(print-values results types stream)
|
||||
(terpri stream)
|
||||
(values results types)))
|
||||
|
||||
|
||||
; Compute the lexer grammar's metagrammar.
|
||||
(defun set-up-lexer-metagrammar (lexer)
|
||||
(setf (lexer-metagrammar lexer) (make-metagrammar (lexer-grammar lexer))))
|
||||
|
||||
|
||||
|
||||
; Parse the input string into elements, where each element is the longest
|
||||
; possible string of input characters that is accepted by the grammar.
|
||||
; The grammar's terminals are all characters that may appear in the input
|
||||
; string plus the symbol $END which is inserted after the last character of
|
||||
; the string.
|
||||
; Return the list of lists of action results of the elements.
|
||||
; If trace is:
|
||||
; nil, don't print trace information
|
||||
; :code, print trace information, including action code
|
||||
; other print trace information
|
||||
; Return two values:
|
||||
; the list of lists of action results;
|
||||
; the list of action results' types. Each of the lists of action results has
|
||||
; this type signature.
|
||||
(defun lexer-metaparse (lexer string &key trace)
|
||||
(let ((metagrammar (lexer-metagrammar lexer)))
|
||||
(do ((in (append (coerce string 'list) '($end)))
|
||||
(results-lists nil))
|
||||
((endp in) (values (nreverse results-lists) (grammar-user-start-action-types (metagrammar-grammar metagrammar))))
|
||||
(multiple-value-bind (results in-rest) (action-metaparse metagrammar (lexer-classifier lexer) in :trace trace)
|
||||
(setq in in-rest)
|
||||
(push results results-lists)))))
|
||||
|
||||
|
||||
; Same as lexer-metaparse except that also print the action results nicely.
|
||||
(defun lexer-pmetaparse (lexer string &key (stream t) trace)
|
||||
(multiple-value-bind (results-lists types) (lexer-metaparse lexer string :trace trace)
|
||||
(pprint-logical-block (stream results-lists)
|
||||
(pprint-exit-if-list-exhausted)
|
||||
(loop
|
||||
(print-values (pprint-pop) types stream :prefix "(" :suffix ")")
|
||||
(pprint-exit-if-list-exhausted)
|
||||
(format stream " ~_")))
|
||||
(terpri stream)
|
||||
(values results-lists types)))
|
||||
|
||||
|
|
@ -0,0 +1,42 @@
|
|||
;;; The contents of this file are subject to the Netscape Public License
|
||||
;;; Version 1.0 (the "NPL"); you may not use this file except in
|
||||
;;; compliance with the NPL. You may obtain a copy of the NPL at
|
||||
;;; http://www.mozilla.org/NPL/
|
||||
;;;
|
||||
;;; Software distributed under the NPL is distributed on an "AS IS" basis,
|
||||
;;; WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
|
||||
;;; for the specific language governing rights and limitations under the
|
||||
;;; NPL.
|
||||
;;;
|
||||
;;; The Initial Developer of this code under the NPL is Netscape
|
||||
;;; Communications Corporation. Portions created by Netscape are
|
||||
;;; Copyright (C) 1998 Netscape Communications Corporation. All Rights
|
||||
;;; Reserved.
|
||||
|
||||
;;;
|
||||
;;; ECMAScript semantic loader
|
||||
;;;
|
||||
;;; Waldemar Horwat (waldemar@netscape.com)
|
||||
;;;
|
||||
|
||||
|
||||
(defparameter *semantic-engine-filenames*
|
||||
'("Utilities" "Markup" "RTF" "HTML" "GrammarSymbol" "Grammar" "Parser" "Metaparser" "Lexer" "Calculus" "CalculusMarkup" "JS14" "ECMA Lexer" "ECMA Grammar"))
|
||||
|
||||
(defparameter *semantic-engine-directory*
|
||||
(make-pathname
|
||||
:directory (pathname-directory (truename *loading-file-source-file*))))
|
||||
|
||||
(defun load-semantic-engine ()
|
||||
(dolist (filename *semantic-engine-filenames*)
|
||||
(let ((pathname (merge-pathnames filename *semantic-engine-directory*)))
|
||||
(load pathname :verbose t))))
|
||||
|
||||
(defmacro with-local-output ((stream filename) &body body)
|
||||
`(with-open-file (,stream (merge-pathnames ,filename *semantic-engine-directory*)
|
||||
:direction :output
|
||||
:if-exists :supersede)
|
||||
,@body))
|
||||
|
||||
|
||||
(load-semantic-engine)
|
||||
|
|
@ -0,0 +1,508 @@
|
|||
;;; The contents of this file are subject to the Netscape Public License
|
||||
;;; Version 1.0 (the "NPL"); you may not use this file except in
|
||||
;;; compliance with the NPL. You may obtain a copy of the NPL at
|
||||
;;; http://www.mozilla.org/NPL/
|
||||
;;;
|
||||
;;; Software distributed under the NPL is distributed on an "AS IS" basis,
|
||||
;;; WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
|
||||
;;; for the specific language governing rights and limitations under the
|
||||
;;; NPL.
|
||||
;;;
|
||||
;;; The Initial Developer of this code under the NPL is Netscape
|
||||
;;; Communications Corporation. Portions created by Netscape are
|
||||
;;; Copyright (C) 1999 Netscape Communications Corporation. All Rights
|
||||
;;; Reserved.
|
||||
|
||||
;;;
|
||||
;;; Common RTF and HTML writing utilities
|
||||
;;;
|
||||
;;; Waldemar Horwat (waldemar@netscape.com)
|
||||
;;;
|
||||
|
||||
|
||||
(defvar *trace-logical-blocks* nil) ;Emit logical blocks to *trace-output* while processing
|
||||
(defvar *show-logical-blocks* nil) ;Emit logical block boundaries as hidden rtf text
|
||||
|
||||
(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
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; MARKUP ENVIRONMENTS
|
||||
|
||||
|
||||
(defstruct (markup-env (:constructor allocate-markup-env (macros widths)))
|
||||
(macros nil :type hash-table :read-only t) ;Hash table of keyword -> expansion list
|
||||
(widths nil :type hash-table :read-only t)) ;Hash table of keyword -> estimated width of macro expansion;
|
||||
; ; zero-width entries can be omitted; multiline entries have t for a width.
|
||||
|
||||
|
||||
(defun make-markup-env ()
|
||||
(allocate-markup-env (make-hash-table :test #'eq) (make-hash-table :test #'eq)))
|
||||
|
||||
|
||||
; Recursively expand all keywords in markup-tree, producing a freshly consed expansion tree.
|
||||
; Allow keywords in the permitted-keywords list to be present in the output without generating an error.
|
||||
(defun markup-env-expand (markup-env markup-tree permitted-keywords)
|
||||
(mapcan
|
||||
#'(lambda (markup-element)
|
||||
(cond
|
||||
((keywordp markup-element)
|
||||
(let ((expansion (gethash markup-element (markup-env-macros markup-env) *get2-nonce*)))
|
||||
(if (eq expansion *get2-nonce*)
|
||||
(if (member markup-element permitted-keywords :test #'eq)
|
||||
(list markup-element)
|
||||
(error "Unknown markup macro ~S" markup-element))
|
||||
(markup-env-expand markup-env expansion permitted-keywords))))
|
||||
((listp markup-element)
|
||||
(list (markup-env-expand markup-env markup-element permitted-keywords)))
|
||||
(t (list markup-element))))
|
||||
markup-tree))
|
||||
|
||||
|
||||
(defun markup-env-define (markup-env keyword expansion &optional width)
|
||||
(assert-type keyword keyword)
|
||||
(assert-type expansion (list t))
|
||||
(assert-type width (or null integer (eql t)))
|
||||
(when (gethash keyword (markup-env-macros markup-env))
|
||||
(warn "Redefining markup macro ~S" keyword))
|
||||
(setf (gethash keyword (markup-env-macros markup-env)) expansion)
|
||||
(if width
|
||||
(setf (gethash keyword (markup-env-widths markup-env)) width)
|
||||
(remhash keyword (markup-env-widths markup-env))))
|
||||
|
||||
|
||||
(defun markup-env-append (markup-env keyword expansion)
|
||||
(assert-type keyword keyword)
|
||||
(assert-type expansion (list t))
|
||||
(setf (gethash keyword (markup-env-macros markup-env))
|
||||
(append (gethash keyword (markup-env-macros markup-env)) expansion)))
|
||||
|
||||
|
||||
(defun markup-env-define-alist (markup-env keywords-and-expansions)
|
||||
(dolist (keyword-and-expansion keywords-and-expansions)
|
||||
(let ((keyword (car keyword-and-expansion))
|
||||
(expansion (cdr keyword-and-expansion)))
|
||||
(cond
|
||||
((not (consp keyword))
|
||||
(markup-env-define markup-env keyword expansion))
|
||||
((eq (first keyword) '+)
|
||||
(markup-env-append markup-env (second keyword) expansion))
|
||||
(t (markup-env-define markup-env (first keyword) expansion (second keyword)))))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; LOGICAL POSITIONS
|
||||
|
||||
(defstruct logical-position
|
||||
(n-hard-breaks 0 :type integer) ;Number of :new-line's in the current paragraph or logical block
|
||||
(position 0 :type integer) ;Current character position. If n-hard-breaks is zero, only includes characters written into this logical block
|
||||
; ; plus the minimal position from the enclosing block. If n-hard-breaks is nonzero, includes indent and characters
|
||||
; ; written since the last hard break.
|
||||
(surplus 0 :type integer) ;Value to subtract from position if soft breaks were hard breaks in this logical block
|
||||
(n-soft-breaks nil :type (or null integer)) ;Number of soft-breaks in the current paragraph or nil if not inside a depict-logical-block
|
||||
(indent 0 :type (or null integer))) ;Indent for next line
|
||||
|
||||
|
||||
; Return the value the position would have if soft breaks became hard breaks in this logical block.
|
||||
(declaim (inline logical-position-minimal-position))
|
||||
(defun logical-position-minimal-position (logical-position)
|
||||
(- (logical-position-position logical-position) (logical-position-surplus logical-position)))
|
||||
|
||||
|
||||
; Advance the logical position by width characters. If width is t,
|
||||
; advance to the next line.
|
||||
(defun logical-position-advance (logical-position width)
|
||||
(if (eq width t)
|
||||
(progn
|
||||
(incf (logical-position-n-hard-breaks logical-position))
|
||||
(setf (logical-position-position logical-position) 0)
|
||||
(setf (logical-position-surplus logical-position) 0))
|
||||
(incf (logical-position-position logical-position) width)))
|
||||
|
||||
|
||||
(defstruct (soft-break (:constructor make-soft-break (width)))
|
||||
(width 0 :type integer)) ;Number of spaces by which to replace this soft break if it doesn't turn into a hard break; t if unconditional
|
||||
|
||||
|
||||
; Destructively replace any soft-break that appears in a car position in the tree with
|
||||
; the spliced result of calling f on that soft-break. f should return a non-null list that can
|
||||
; be nconc'd.
|
||||
(defun substitute-soft-breaks (tree f)
|
||||
(do ((subtree tree next-subtree)
|
||||
(next-subtree (cdr tree) (cdr next-subtree)))
|
||||
((endp subtree))
|
||||
(let ((item (car subtree)))
|
||||
(cond
|
||||
((soft-break-p item)
|
||||
(let* ((splice (assert-non-null (funcall f item)))
|
||||
(splice-rest (cdr splice)))
|
||||
(setf (car subtree) (car splice))
|
||||
(setf (cdr subtree) (nconc splice-rest next-subtree))))
|
||||
((consp item) (substitute-soft-breaks item f)))))
|
||||
tree)
|
||||
|
||||
|
||||
; Destructively replace any soft-break that appears in a car position in the tree
|
||||
; with width spaces, where width is the soft-break's width.
|
||||
(defun remove-soft-breaks (tree)
|
||||
(substitute-soft-breaks
|
||||
tree
|
||||
#'(lambda (soft-break)
|
||||
(list (make-string (soft-break-width soft-break) :initial-element #\space :element-type 'base-character)))))
|
||||
|
||||
|
||||
; 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 'base-character))))
|
||||
|
||||
|
||||
; Destructively replace any soft-break that appears in a car position in the tree
|
||||
; with a line break followed by indent spaces.
|
||||
(defun expand-soft-breaks (tree indent)
|
||||
(substitute-soft-breaks
|
||||
tree
|
||||
#'(lambda (soft-break)
|
||||
(declare (ignore soft-break))
|
||||
(hard-break-markup indent))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; MARKUP STREAMS
|
||||
|
||||
(defstruct (markup-stream (:copier nil) (:predicate markup-stream?))
|
||||
(env nil :type markup-env :read-only t)
|
||||
(level nil :type integer) ;0 for emitting top-level group; 1 for emitting sections; 2 for emitting paragraphs; 3 for emitting paragraph contents
|
||||
(head nil :type list) ;Pointer to a dummy cons-cell whose cdr is the output markup list.
|
||||
; ; 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-position nil :type logical-position)) ;Information about the current logical lines or nil if not emitting paragraph contents
|
||||
|
||||
; ;RTF ;HTML
|
||||
(defconstant *markup-stream-top-level* 0) ;Top-level group ;Top level
|
||||
(defconstant *markup-stream-section-level* 1) ;Sections ;(not used)
|
||||
(defconstant *markup-stream-paragraph-level* 2) ;Paragraphs ;Block tags
|
||||
(defconstant *markup-stream-content-level* 3) ;Paragraph contents ;Inline tags
|
||||
|
||||
|
||||
; 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)
|
||||
(when (markup-stream-pretail markup-stream)
|
||||
;Inline the last block at the end of the markup-stream.
|
||||
(setf (cdr (markup-stream-pretail markup-stream)) (car (markup-stream-tail markup-stream)))
|
||||
(setf (markup-stream-pretail markup-stream) nil))
|
||||
(setf (markup-stream-tail markup-stream) nil) ;Close the stream.
|
||||
(cdr (assert-non-null (markup-stream-head markup-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.
|
||||
(defgeneric markup-stream-output (markup-stream))
|
||||
|
||||
|
||||
; Append one item to the end of the markup-stream.
|
||||
(defun markup-stream-append1 (markup-stream item)
|
||||
(setf (markup-stream-pretail markup-stream) nil)
|
||||
(let ((item-cons (list item)))
|
||||
(setf (cdr (markup-stream-tail markup-stream)) item-cons)
|
||||
(setf (markup-stream-tail markup-stream) item-cons)))
|
||||
|
||||
|
||||
; Return the approximate width of the markup item; return t if it is a line break.
|
||||
(defun markup-width (markup-stream item)
|
||||
(cond
|
||||
((stringp item) (round (- (length item) (* (count #\space item) (- 1 *average-space-width*)))))
|
||||
((keywordp item) (gethash item (markup-env-widths (markup-stream-env markup-stream)) 0))
|
||||
((and item (symbolp item)) 0)
|
||||
(t (error "Bad item in markup-width" item))))
|
||||
|
||||
|
||||
; Return the approximate width of the markup item; return t if it is a line break.
|
||||
; Also allow markup groups as long as they do not contain line breaks.
|
||||
(defgeneric markup-group-width (markup-stream item))
|
||||
|
||||
|
||||
; Append zero or more markup items to the end of the markup-stream.
|
||||
; The items must be either keywords, symbols, or strings.
|
||||
(defun depict (markup-stream &rest markup-list)
|
||||
(assert-true (>= (markup-stream-level markup-stream) *markup-stream-content-level*))
|
||||
(dolist (markup markup-list)
|
||||
(markup-stream-append1 markup-stream markup)
|
||||
(logical-position-advance (markup-stream-logical-position markup-stream) (markup-width markup-stream markup))))
|
||||
|
||||
|
||||
; Same as depict except that the items may be groups as well.
|
||||
(defun depict-group (markup-stream &rest markup-list)
|
||||
(assert-true (>= (markup-stream-level markup-stream) *markup-stream-content-level*))
|
||||
(dolist (markup markup-list)
|
||||
(markup-stream-append1 markup-stream markup)
|
||||
(logical-position-advance (markup-stream-logical-position markup-stream) (markup-group-width markup-stream markup))))
|
||||
|
||||
|
||||
; If markup-item-or-list is a list, emit its contents via depict.
|
||||
; If markup-item-or-list is not a list, emit it via depict.
|
||||
(defun depict-item-or-list (markup-stream markup-item-or-list)
|
||||
(if (listp markup-item-or-list)
|
||||
(apply #'depict markup-stream markup-item-or-list)
|
||||
(depict markup-stream markup-item-or-list)))
|
||||
|
||||
|
||||
; If markup-item-or-list is a list, emit its contents via depict-group.
|
||||
; If markup-item-or-list is not a list, emit it via depict.
|
||||
(defun depict-item-or-group-list (markup-stream markup-item-or-list)
|
||||
(if (listp markup-item-or-list)
|
||||
(apply #'depict-group markup-stream markup-item-or-list)
|
||||
(depict markup-stream markup-item-or-list)))
|
||||
|
||||
|
||||
; 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 block-style is applied to all
|
||||
; paragraphs emitted by body (in the HTML emitter only; RTF has no block styles).
|
||||
; Return the result value of body.
|
||||
(defmacro depict-block-style ((markup-stream block-style) &body body)
|
||||
`(depict-block-style-f ,markup-stream ,block-style
|
||||
#'(lambda (,markup-stream) ,@body)))
|
||||
|
||||
(defgeneric depict-block-style-f (markup-stream block-style emitter))
|
||||
|
||||
|
||||
; markup-stream must be a variable that names a markup-stream that is currently
|
||||
; accepting paragraphs. Emit a paragraph with the given paragraph-style (which
|
||||
; must be a symbol) whose contents are emitted by body. When executing body,
|
||||
; markup-stream is bound to a markup-stream to which body should emit the paragraph's contents.
|
||||
; Return the result value of body.
|
||||
(defmacro depict-paragraph ((markup-stream paragraph-style) &body body)
|
||||
`(depict-paragraph-f ,markup-stream ,paragraph-style
|
||||
#'(lambda (,markup-stream) ,@body)))
|
||||
|
||||
(defgeneric depict-paragraph-f (markup-stream paragraph-style emitter))
|
||||
|
||||
|
||||
; markup-stream must be a variable that names a markup-stream that is currently
|
||||
; accepting paragraph contents. Execute body with markup-stream bound to a markup-stream
|
||||
; to which the body can emit contents. The given char-style is applied to all such
|
||||
; contents emitted by body.
|
||||
; Return the result value of body.
|
||||
(defmacro depict-char-style ((markup-stream char-style) &body body)
|
||||
`(depict-char-style-f ,markup-stream ,char-style
|
||||
#'(lambda (,markup-stream) ,@body)))
|
||||
|
||||
(defgeneric depict-char-style-f (markup-stream char-style emitter))
|
||||
|
||||
|
||||
(defun depict-logical-block-f (markup-stream indent emitter)
|
||||
(assert-true (>= (markup-stream-level markup-stream) *markup-stream-content-level*))
|
||||
(if indent
|
||||
(let* ((logical-position (markup-stream-logical-position markup-stream))
|
||||
(cumulative-indent (+ (logical-position-indent logical-position) indent))
|
||||
(minimal-position (logical-position-minimal-position logical-position))
|
||||
(inner-logical-position (make-logical-position :position minimal-position
|
||||
:n-soft-breaks 0
|
||||
:indent cumulative-indent))
|
||||
(old-tail (markup-stream-tail markup-stream)))
|
||||
(setf (markup-stream-logical-position markup-stream) inner-logical-position)
|
||||
(when *show-logical-blocks*
|
||||
(markup-stream-append1 markup-stream (list ':invisible (format nil "<~D" indent))))
|
||||
(prog1
|
||||
(funcall emitter markup-stream)
|
||||
(when *show-logical-blocks*
|
||||
(markup-stream-append1 markup-stream '(:invisible ">")))
|
||||
(assert-true (eq (markup-stream-logical-position markup-stream) inner-logical-position))
|
||||
(let* ((tree (cdr old-tail))
|
||||
(inner-position (logical-position-position inner-logical-position))
|
||||
(inner-count (- inner-position minimal-position))
|
||||
(inner-n-hard-breaks (logical-position-n-hard-breaks inner-logical-position))
|
||||
(inner-n-soft-breaks (logical-position-n-soft-breaks inner-logical-position)))
|
||||
(when *trace-logical-blocks*
|
||||
(format *trace-output* "Block ~:W:~%position ~D, count ~D, n-hard-breaks ~D, n-soft-breaks ~D~%~%"
|
||||
tree inner-position inner-count inner-n-hard-breaks inner-n-soft-breaks))
|
||||
(cond
|
||||
((zerop inner-n-soft-breaks)
|
||||
(assert-true (zerop (logical-position-surplus inner-logical-position)))
|
||||
(if (zerop inner-n-hard-breaks)
|
||||
(incf (logical-position-position logical-position) inner-count)
|
||||
(progn
|
||||
(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*))
|
||||
(assert-true tree)
|
||||
(remove-soft-breaks tree)
|
||||
(incf (logical-position-position logical-position) inner-count))
|
||||
(t
|
||||
(assert-true tree)
|
||||
(expand-soft-breaks tree cumulative-indent)
|
||||
(incf (logical-position-n-hard-breaks logical-position) (+ inner-n-hard-breaks inner-n-soft-breaks))
|
||||
(setf (logical-position-position logical-position) (logical-position-minimal-position inner-logical-position))
|
||||
(setf (logical-position-surplus logical-position) 0))))
|
||||
(setf (markup-stream-logical-position markup-stream) logical-position)))
|
||||
(funcall emitter markup-stream)))
|
||||
|
||||
|
||||
; markup-stream must be a variable that names a markup-stream that is currently
|
||||
; accepting paragraph contents. Execute body with markup-stream bound to a markup-stream
|
||||
; to which the body can emit contents. body can call depict-break, which will either
|
||||
; all expand to the widths given to the depict-break calls or all expand to line breaks
|
||||
; followed by indents to the current indent level plus the given indent.
|
||||
; If indent is nil, don't create the logical block and just evaluate body.
|
||||
; Return the result value of body.
|
||||
(defmacro depict-logical-block ((markup-stream indent) &body body)
|
||||
`(depict-logical-block-f ,markup-stream ,indent
|
||||
#'(lambda (,markup-stream) ,@body)))
|
||||
|
||||
|
||||
; Emit a conditional line break. If the line break is not needed, emit width spaces instead.
|
||||
; If width is t or omitted, the line break is unconditional.
|
||||
; If width is nil, do nothing.
|
||||
; If the line break is needed, the new line is indented to the current indent level.
|
||||
; Must be called from the dynamic scope of a depict-logical-block.
|
||||
(defun depict-break (markup-stream &optional (width t))
|
||||
(assert-true (>= (markup-stream-level markup-stream) *markup-stream-content-level*))
|
||||
(when width
|
||||
(let* ((logical-position (markup-stream-logical-position markup-stream))
|
||||
(indent (logical-position-indent logical-position)))
|
||||
(if (eq width t)
|
||||
(depict-item-or-list markup-stream (hard-break-markup indent))
|
||||
(progn
|
||||
(incf (logical-position-n-soft-breaks logical-position))
|
||||
(incf (logical-position-position logical-position) width)
|
||||
(let ((surplus (- (logical-position-position logical-position) (round (* indent *average-space-width*)))))
|
||||
(when (< surplus 0)
|
||||
(setq surplus 0))
|
||||
(setf (logical-position-surplus logical-position) surplus))
|
||||
(when *show-logical-blocks*
|
||||
(markup-stream-append1 markup-stream '(:invisible :bullet)))
|
||||
(markup-stream-append1 markup-stream (make-soft-break width)))))))
|
||||
|
||||
|
||||
; Call emitter to emit each element of the given list onto the markup-stream.
|
||||
; emitter takes two arguments -- the markup-stream and the element of list to be emitted.
|
||||
; Emit prefix before the list and suffix after the list. If prefix-break is supplied, call
|
||||
; depict-break with it as the argument after the prefix.
|
||||
; If indent is non-nil, enclose the list elements in a logical block with the given indent.
|
||||
; Emit separator between any two emitted elements. If break is supplied, call
|
||||
; depict-break with it as the argument after each separator.
|
||||
; If the list is empty, emit empty unless it is :error, in which case signal an error.
|
||||
;
|
||||
; prefix, suffix, separator, and empty should be lists of markup elements appropriate for depict.
|
||||
; If any of these lists has only one element that is not itself a list, then that list can be
|
||||
; abbreviated to just that element (as in depict-item-or-list).
|
||||
;
|
||||
(defun depict-list (markup-stream emitter list &key indent prefix prefix-break suffix separator break (empty :error))
|
||||
(assert-true (or indent (not (or prefix-break break))))
|
||||
(labels
|
||||
((emit-element (markup-stream list)
|
||||
(funcall emitter markup-stream (first list))
|
||||
(let ((rest (rest list)))
|
||||
(when rest
|
||||
(depict-item-or-list markup-stream separator)
|
||||
(depict-break markup-stream break)
|
||||
(emit-element markup-stream rest)))))
|
||||
|
||||
(depict-item-or-list markup-stream prefix)
|
||||
(cond
|
||||
(list
|
||||
(depict-logical-block (markup-stream indent)
|
||||
(depict-break markup-stream prefix-break)
|
||||
(emit-element markup-stream list)))
|
||||
((eq empty ':error) (error "Non-empty list required"))
|
||||
(t (depict-item-or-list markup-stream empty)))
|
||||
(depict-item-or-list markup-stream suffix)))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; MARKUP FOR CHARACTERS AND STRINGS
|
||||
|
||||
(defparameter *character-names*
|
||||
'((#x00 . "NUL")
|
||||
(#x08 . "BS")
|
||||
(#x09 . "TAB")
|
||||
(#x0A . "LF")
|
||||
(#x0B . "VT")
|
||||
(#x0C . "FF")
|
||||
(#x0D . "CR")
|
||||
(#x20 . "SP")))
|
||||
|
||||
; Emit markup for the given character. The character is emitted without any formatting if it is a
|
||||
; printable character and not a member of the escape-list list of characters. Otherwise the
|
||||
; character is emitted with :character-literal-control formatting.
|
||||
; The markup-stream should already be set to :character-literal formatting.
|
||||
(defun depict-character (markup-stream char &optional (escape-list '(#\space)))
|
||||
(let ((code (char-code char)))
|
||||
(if (and (>= code 32) (< code 127) (not (member char escape-list)))
|
||||
(depict markup-stream (string char))
|
||||
(depict-char-style (markup-stream ':character-literal-control)
|
||||
(let ((name (or (cdr (assoc code *character-names*))
|
||||
(format nil "u~4,'0X" code))))
|
||||
(depict markup-stream ':left-angle-quote name ':right-angle-quote))))))
|
||||
|
||||
|
||||
; Emit markup for the given string, enclosing it in curly double quotes.
|
||||
; The markup-stream should be set to normal formatting.
|
||||
(defun depict-string (markup-stream string)
|
||||
(depict markup-stream ':left-double-quote)
|
||||
(unless (equal string "")
|
||||
(depict-char-style (markup-stream ':character-literal)
|
||||
(dotimes (i (length string))
|
||||
(depict-character markup-stream (char string i) nil))))
|
||||
(depict markup-stream ':right-double-quote))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; MARKUP FOR IDENTIFIERS
|
||||
|
||||
; Return string converted from dash-separated-uppercase-words to mixed case,
|
||||
; with the first character capitalized if capitalize is true.
|
||||
; The string should contain only letters, dashes, and numbers.
|
||||
(defun string-to-mixed-case (string &optional capitalize)
|
||||
(let* ((length (length string))
|
||||
(dst-string (make-array length :element-type 'base-character :fill-pointer 0)))
|
||||
(dotimes (i length)
|
||||
(let ((char (char string i)))
|
||||
(if (eql char #\-)
|
||||
(if capitalize
|
||||
(error "Double capitalize")
|
||||
(setq capitalize t))
|
||||
(progn
|
||||
(cond
|
||||
((upper-case-p char)
|
||||
(if capitalize
|
||||
(setq capitalize nil)
|
||||
(setq char (char-downcase char))))
|
||||
((digit-char-p char))
|
||||
((member char '(#\$ #\_)))
|
||||
(t (error "Bad string-to-mixed-case character ~A" char)))
|
||||
(vector-push char dst-string)))))
|
||||
dst-string))
|
||||
|
||||
|
||||
; Return a string containing the symbol's name in mixed case with the first letter capitalized.
|
||||
(defun symbol-upper-mixed-case-name (symbol)
|
||||
(or (get symbol :upper-mixed-case-name)
|
||||
(setf (get symbol :upper-mixed-case-name) (string-to-mixed-case (symbol-name symbol) t))))
|
||||
|
||||
|
||||
; Return a string containing the symbol's name in mixed case with the first letter in lower case.
|
||||
(defun symbol-lower-mixed-case-name (symbol)
|
||||
(or (get symbol :lower-mixed-case-name)
|
||||
(setf (get symbol :lower-mixed-case-name) (string-to-mixed-case (symbol-name symbol)))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; MISCELLANEOUS MARKUP
|
||||
|
||||
|
||||
; Append a space to the end of the markup-stream.
|
||||
(defun depict-space (markup-stream)
|
||||
(depict markup-stream " "))
|
||||
|
||||
|
||||
; Emit markup for the given integer, displaying it in decimal.
|
||||
(defun depict-integer (markup-stream i)
|
||||
(depict markup-stream (format nil "~D" i)))
|
||||
|
||||
|
|
@ -0,0 +1,356 @@
|
|||
;;; The contents of this file are subject to the Netscape Public License
|
||||
;;; Version 1.0 (the "NPL"); you may not use this file except in
|
||||
;;; compliance with the NPL. You may obtain a copy of the NPL at
|
||||
;;; http://www.mozilla.org/NPL/
|
||||
;;;
|
||||
;;; Software distributed under the NPL is distributed on an "AS IS" basis,
|
||||
;;; WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
|
||||
;;; for the specific language governing rights and limitations under the
|
||||
;;; NPL.
|
||||
;;;
|
||||
;;; The Initial Developer of this code under the NPL is Netscape
|
||||
;;; Communications Corporation. Portions created by Netscape are
|
||||
;;; Copyright (C) 1998 Netscape Communications Corporation. All Rights
|
||||
;;; Reserved.
|
||||
|
||||
;;;
|
||||
;;; Finite-state machine generator
|
||||
;;;
|
||||
;;; Waldemar Horwat (waldemar@netscape.com)
|
||||
;;;
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; METATRANSITION
|
||||
|
||||
(defstruct (metatransition (:constructor make-metatransition (next-metastate pre-productions post-productions)))
|
||||
(next-metastate nil :read-only t) ;Next metastate to enter or nil if this is an accept transition
|
||||
(pre-productions nil :read-only t) ;List of productions reduced by this transition (in order from first to last) before the shift
|
||||
(post-productions nil :read-only t)) ;List of productions reduced by this transition (in order from first to last) after the shift
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; METASTATE
|
||||
|
||||
;;; A metastate is a list of states that represents a possible stack that the
|
||||
;;; LALR(1) parser may encounter.
|
||||
(defstruct (metastate (:constructor make-metastate (stack number transitions)))
|
||||
(stack nil :type list :read-only t) ;List of states that comprises a possible stack
|
||||
(number nil :type integer :read-only t) ;Serial number of this metastate
|
||||
(transitions nil :type simple-vector :read-only t)) ;Array, indexed by terminal numbers, of either nil or metatransition structures
|
||||
|
||||
(declaim (inline metastate-transition))
|
||||
(defun metastate-transition (metastate terminal-number)
|
||||
(svref (metastate-transitions metastate) terminal-number))
|
||||
|
||||
|
||||
(defun print-metastate (metastate metagrammar &optional (stream t))
|
||||
(let ((grammar (metagrammar-grammar metagrammar)))
|
||||
(pprint-logical-block (stream nil)
|
||||
(format stream "M~D:~2I ~@_~<~@{S~D ~:_~}~:>~:@_"
|
||||
(metastate-number metastate)
|
||||
(nreverse (mapcar #'state-number (metastate-stack metastate))))
|
||||
(let ((transitions (metastate-transitions metastate)))
|
||||
(dotimes (terminal-number (length transitions))
|
||||
(let ((transition (svref transitions terminal-number))
|
||||
(terminal (svref (grammar-terminals grammar) terminal-number)))
|
||||
(when transition
|
||||
(let ((next-metastate (metatransition-next-metastate transition)))
|
||||
(pprint-logical-block (stream nil)
|
||||
(format stream "~W ==> ~@_~:I~:[accept~;M~:*~D~] ~_"
|
||||
terminal
|
||||
(and next-metastate (metastate-number next-metastate)))
|
||||
(pprint-fill stream (mapcar #'production-name (metatransition-pre-productions transition)))
|
||||
(format stream " ~@_")
|
||||
(pprint-fill stream (mapcar #'production-name (metatransition-post-productions transition))))
|
||||
(pprint-newline :mandatory stream)))))))))
|
||||
|
||||
|
||||
(defmethod print-object ((metastate metastate) stream)
|
||||
(print-unreadable-object (metastate stream)
|
||||
(format stream "metastate S~D" (metastate-number metastate))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; METAGRAMMAR
|
||||
|
||||
(defstruct (metagrammar (:constructor allocate-metagrammar))
|
||||
(grammar nil :type grammar :read-only t) ;The grammar to which this metagrammar corresponds
|
||||
(metastates nil :type list :read-only t) ;List of metastates ordered by metastate numbers
|
||||
(start nil :type metastate :read-only t)) ;The start metastate
|
||||
|
||||
|
||||
(defun make-metagrammar (grammar)
|
||||
(let* ((terminals (grammar-terminals grammar))
|
||||
(n-terminals (length terminals))
|
||||
(metastates-hash (make-hash-table :test #'equal)) ;Hash table of (list of state) -> metastate
|
||||
(metastates nil)
|
||||
(metastate-number -1))
|
||||
(labels
|
||||
(;Return the stack after applying the given reduction production.
|
||||
(apply-reduction-production (stack production)
|
||||
(let* ((stack (nthcdr (production-rhs-length production) stack))
|
||||
(state (first stack))
|
||||
(dst-state (assert-non-null
|
||||
(cdr (assoc (production-lhs production) (state-gotos state) :test *grammar-symbol-=*))))
|
||||
(dst-stack (cons dst-state stack)))
|
||||
(if (member dst-state stack :test #'eq)
|
||||
(error "This grammar cannot be represented by a FSM. Stack: ~S" dst-stack)
|
||||
dst-stack)))
|
||||
|
||||
(get-metatransition (stack terminal productions)
|
||||
(let* ((state (first stack))
|
||||
(transition (cdr (assoc terminal (state-transitions state) :test *grammar-symbol-=*))))
|
||||
(when transition
|
||||
(case (transition-kind transition)
|
||||
(:shift
|
||||
(multiple-value-bind (metastate forwarding-productions) (get-metastate (transition-state transition) stack t)
|
||||
(make-metatransition metastate (nreverse productions) forwarding-productions)))
|
||||
(:reduce
|
||||
(let ((production (transition-production transition)))
|
||||
(get-metatransition (apply-reduction-production stack production) terminal (cons production productions))))
|
||||
(:accept (make-metatransition nil (nreverse productions) nil))
|
||||
(t (error "Bad transition: ~S" transition))))))
|
||||
|
||||
;Return the metastate corresponding to the state stack (stack-top . stack-rest). Construct a new
|
||||
;metastate if necessary.
|
||||
;If simplify is true and stack-top is a state for which every outgoing transition is the same
|
||||
;reduction, return two values:
|
||||
; the metastate reached by following that reduction (doing it recursively if needed)
|
||||
; a list of reduction productions followed this way.
|
||||
(get-metastate (stack-top stack-rest simplify)
|
||||
(let* ((stack (cons stack-top stack-rest))
|
||||
(existing-metastate (gethash stack metastates-hash)))
|
||||
(cond
|
||||
(existing-metastate (values existing-metastate nil))
|
||||
((member stack-top stack-rest :test #'eq)
|
||||
(error "This grammar cannot be represented by a FSM. Stack: ~S" stack))
|
||||
(t (let ((forwarding-production (and simplify (forwarding-state-production stack-top))))
|
||||
(if forwarding-production
|
||||
(let ((stack (apply-reduction-production stack forwarding-production)))
|
||||
(multiple-value-bind (metastate forwarding-productions) (get-metastate (car stack) (cdr stack) simplify)
|
||||
(values metastate (cons forwarding-production forwarding-productions))))
|
||||
(let* ((transitions (make-array n-terminals :initial-element nil))
|
||||
(metastate (make-metastate stack (incf metastate-number) transitions)))
|
||||
(setf (gethash stack metastates-hash) metastate)
|
||||
(push metastate metastates)
|
||||
(dotimes (n n-terminals)
|
||||
(setf (svref transitions n)
|
||||
(get-metatransition stack (svref terminals n) nil)))
|
||||
(values metastate nil)))))))))
|
||||
|
||||
(let ((start-metastate (get-metastate (grammar-start-state grammar) nil nil)))
|
||||
(allocate-metagrammar :grammar grammar
|
||||
:metastates (nreverse metastates)
|
||||
:start start-metastate)))))
|
||||
|
||||
|
||||
; Print the metagrammar nicely.
|
||||
(defun print-metagrammar (metagrammar &optional (stream t) &key (grammar t) (details t))
|
||||
(pprint-logical-block (stream nil)
|
||||
(when grammar
|
||||
(print-grammar (metagrammar-grammar metagrammar) stream :details details))
|
||||
|
||||
;Print the metastates.
|
||||
(format stream "Start metastate: ~@_M~D~:@_~:@_" (metastate-number (metagrammar-start metagrammar)))
|
||||
(pprint-logical-block (stream (metagrammar-metastates metagrammar))
|
||||
(pprint-exit-if-list-exhausted)
|
||||
(format stream "Metastates:~2I~:@_")
|
||||
(loop
|
||||
(print-metastate (pprint-pop) metagrammar stream)
|
||||
(pprint-exit-if-list-exhausted)
|
||||
(pprint-newline :mandatory stream))))
|
||||
(pprint-newline :mandatory stream))
|
||||
|
||||
|
||||
(defmethod print-object ((metagrammar metagrammar) stream)
|
||||
(print-unreadable-object (metagrammar stream :identity t)
|
||||
(write-string "metagrammar" stream)))
|
||||
|
||||
|
||||
; Find the longest possible prefix of the input list of tokens that is accepted by the
|
||||
; grammar. Parse that prefix and return two values:
|
||||
; the list of action results;
|
||||
; the tail of the input list of tokens remaining to be parsed.
|
||||
; Signal an error if no prefix of the input list is accepted by the grammar.
|
||||
;
|
||||
; token-terminal is a function that returns a terminal symbol when given an input token.
|
||||
; If trace is:
|
||||
; nil, don't print trace information
|
||||
; :code, print trace information, including action code
|
||||
; other print trace information
|
||||
(defun action-metaparse (metagrammar token-terminal input &key trace)
|
||||
(if trace
|
||||
(trace-action-metaparse metagrammar token-terminal input trace)
|
||||
(let ((grammar (metagrammar-grammar metagrammar)))
|
||||
(labels
|
||||
((transition-value-stack (value-stack productions)
|
||||
(dolist (production productions)
|
||||
(setq value-stack (funcall (production-evaluator production) value-stack)))
|
||||
value-stack)
|
||||
|
||||
(cut (input good-metastate good-input good-value-stack)
|
||||
(unless good-metastate
|
||||
(error "Parse error on ~S ..." (ldiff input (nthcdr 10 input))))
|
||||
(let ((last-metatransition (metastate-transition good-metastate *end-marker-terminal-number*)))
|
||||
(assert-true (null (metatransition-next-metastate last-metatransition)))
|
||||
(assert-true (null (metatransition-post-productions last-metatransition)))
|
||||
(values
|
||||
(reverse (transition-value-stack good-value-stack (metatransition-pre-productions last-metatransition)))
|
||||
good-input))))
|
||||
|
||||
(do ((metastate (metagrammar-start metagrammar))
|
||||
(input input (cdr input))
|
||||
(value-stack nil)
|
||||
(last-good-metastate nil)
|
||||
last-good-input
|
||||
last-good-value-stack)
|
||||
(nil)
|
||||
(when (metastate-transition metastate *end-marker-terminal-number*)
|
||||
(setq last-good-metastate metastate)
|
||||
(setq last-good-input input)
|
||||
(setq last-good-value-stack value-stack))
|
||||
(when (endp input)
|
||||
(return (cut input last-good-metastate last-good-input last-good-value-stack)))
|
||||
(let* ((token (first input))
|
||||
(terminal (funcall token-terminal token))
|
||||
(terminal-number (terminal-number grammar terminal))
|
||||
(metatransition (metastate-transition metastate terminal-number)))
|
||||
(unless metatransition
|
||||
(return (cut input last-good-metastate last-good-input last-good-value-stack)))
|
||||
(setq value-stack (transition-value-stack value-stack (metatransition-pre-productions metatransition)))
|
||||
(dolist (action-function-binding (gethash terminal (grammar-terminal-actions grammar)))
|
||||
(push (funcall (cdr action-function-binding) token) value-stack))
|
||||
(setq value-stack (transition-value-stack value-stack (metatransition-post-productions metatransition)))
|
||||
(setq metastate (metatransition-next-metastate metatransition))))))))
|
||||
|
||||
|
||||
; Same as action-parse, but with tracing information
|
||||
; If trace is:
|
||||
; :code, print trace information, including action code
|
||||
; other print trace information
|
||||
(defun trace-action-metaparse (metagrammar token-terminal input trace)
|
||||
(let
|
||||
((grammar (metagrammar-grammar metagrammar)))
|
||||
(labels
|
||||
((print-stacks (value-stack type-stack)
|
||||
(write-string " " *trace-output*)
|
||||
(if value-stack
|
||||
(print-values (reverse value-stack) (reverse type-stack) *trace-output*)
|
||||
(write-string "empty" *trace-output*))
|
||||
(pprint-newline :mandatory *trace-output*))
|
||||
|
||||
(transition-value-stack (value-stack type-stack productions)
|
||||
(dolist (production productions)
|
||||
(write-string " reduce " *trace-output*)
|
||||
(if (eq trace :code)
|
||||
(write production :stream *trace-output* :pretty t)
|
||||
(print-production production *trace-output*))
|
||||
(pprint-newline :mandatory *trace-output*)
|
||||
(setq value-stack (funcall (production-evaluator production) value-stack))
|
||||
(setq type-stack (nthcdr (production-n-action-args production) type-stack))
|
||||
(dolist (action-signature (grammar-symbol-signature grammar (production-lhs production)))
|
||||
(push (cdr action-signature) type-stack))
|
||||
(print-stacks value-stack type-stack))
|
||||
(values value-stack type-stack))
|
||||
|
||||
(cut (input good-metastate good-input good-value-stack good-type-stack)
|
||||
(unless good-metastate
|
||||
(error "Parse error on ~S ..." (ldiff input (nthcdr 10 input))))
|
||||
(let ((last-metatransition (metastate-transition good-metastate *end-marker-terminal-number*)))
|
||||
(assert-true (null (metatransition-next-metastate last-metatransition)))
|
||||
(assert-true (null (metatransition-post-productions last-metatransition)))
|
||||
(format *trace-output* "cut to M~D~:@_" (metastate-number good-metastate))
|
||||
(print-stacks good-value-stack good-type-stack)
|
||||
(pprint-newline :mandatory *trace-output*)
|
||||
(values
|
||||
(reverse (transition-value-stack good-value-stack good-type-stack (metatransition-pre-productions last-metatransition)))
|
||||
good-input))))
|
||||
|
||||
(do ((metastate (metagrammar-start metagrammar))
|
||||
(input input (cdr input))
|
||||
(value-stack nil)
|
||||
(type-stack nil)
|
||||
(last-good-metastate nil)
|
||||
last-good-input
|
||||
last-good-value-stack
|
||||
last-good-type-stack)
|
||||
(nil)
|
||||
(format *trace-output* "M~D" (metastate-number metastate))
|
||||
(when (metastate-transition metastate *end-marker-terminal-number*)
|
||||
(write-string " (good)" *trace-output*)
|
||||
(setq last-good-metastate metastate)
|
||||
(setq last-good-input input)
|
||||
(setq last-good-value-stack value-stack)
|
||||
(setq last-good-type-stack type-stack))
|
||||
(write-string ": " *trace-output*)
|
||||
(when (endp input)
|
||||
(return (cut input last-good-metastate last-good-input last-good-value-stack last-good-type-stack)))
|
||||
(let* ((token (first input))
|
||||
(terminal (funcall token-terminal token))
|
||||
(terminal-number (terminal-number grammar terminal))
|
||||
(metatransition (metastate-transition metastate terminal-number)))
|
||||
(unless metatransition
|
||||
(format *trace-output* "shift ~W: " terminal)
|
||||
(return (cut input last-good-metastate last-good-input last-good-value-stack last-good-type-stack)))
|
||||
(format *trace-output* "transition to M~D~:@_" (metastate-number (metatransition-next-metastate metatransition)))
|
||||
(multiple-value-setq (value-stack type-stack)
|
||||
(transition-value-stack value-stack type-stack (metatransition-pre-productions metatransition)))
|
||||
(dolist (action-function-binding (gethash terminal (grammar-terminal-actions grammar)))
|
||||
(push (funcall (cdr action-function-binding) token) value-stack))
|
||||
(dolist (action-signature (grammar-symbol-signature grammar terminal))
|
||||
(push (cdr action-signature) type-stack))
|
||||
(format *trace-output* "shift ~W~:@_" terminal)
|
||||
(print-stacks value-stack type-stack)
|
||||
(multiple-value-setq (value-stack type-stack)
|
||||
(transition-value-stack value-stack type-stack (metatransition-post-productions metatransition)))
|
||||
(setq metastate (metatransition-next-metastate metatransition)))))))
|
||||
|
||||
|
||||
; Compute all representative strings of terminals such that, for each such string S:
|
||||
; S is rejected by the grammar's language;
|
||||
; all prefixes of S are also rejected by the grammar's language;
|
||||
; for any S and all strings of terminals T, the concatenated string ST is also
|
||||
; rejected by the grammar's language;
|
||||
; no string S1 is a prefix of (or equal to) another string S2.
|
||||
; Often there are infinitely many such strings S, so only output one for each illegal
|
||||
; metaparser transition.
|
||||
; Return a list of S's, where each S is itself a list of terminals.
|
||||
(defun compute-illegal-strings (metagrammar)
|
||||
(let* ((grammar (metagrammar-grammar metagrammar))
|
||||
(terminals (grammar-terminals grammar))
|
||||
(n-terminals (length terminals))
|
||||
(metastates (metagrammar-metastates metagrammar))
|
||||
(n-metastates (length metastates))
|
||||
(visited-metastates (make-array n-metastates :element-type 'bit :initial-element 0))
|
||||
(illegal-strings nil))
|
||||
(labels
|
||||
((visit (metastate reversed-string)
|
||||
(let ((metastate-number (metastate-number metastate)))
|
||||
(when (= (sbit visited-metastates metastate-number) 0)
|
||||
(setf (sbit visited-metastates metastate-number) 1)
|
||||
(let ((metatransitions (metastate-transitions metastate)))
|
||||
;If there is a transition for the end marker from this state, then string
|
||||
;is accepted by the language, so cut off the search.
|
||||
(unless (svref metatransitions *end-marker-terminal-number*)
|
||||
(dotimes (terminal-number n-terminals)
|
||||
(unless (= terminal-number *end-marker-terminal-number*)
|
||||
(let ((metatransition (svref metatransitions terminal-number))
|
||||
(reversed-string (cons (svref terminals terminal-number) reversed-string)))
|
||||
(if metatransition
|
||||
(visit (metatransition-next-metastate metatransition) reversed-string)
|
||||
(push (reverse reversed-string) illegal-strings)))))))))))
|
||||
|
||||
(visit (metagrammar-start metagrammar) nil)
|
||||
(nreverse illegal-strings))))
|
||||
|
||||
|
||||
; Compute and print illegal strings of terminals. See compute-illegal-strings.
|
||||
(defun print-illegal-strings (metagrammar &optional (stream t))
|
||||
(pprint-logical-block (stream (compute-illegal-strings metagrammar))
|
||||
(format stream "Illegal strings:~2I")
|
||||
(loop
|
||||
(pprint-exit-if-list-exhausted)
|
||||
(pprint-newline :mandatory stream)
|
||||
(pprint-fill stream (pprint-pop))))
|
||||
(pprint-newline :mandatory stream))
|
||||
|
|
@ -0,0 +1,675 @@
|
|||
;;; The contents of this file are subject to the Netscape Public License
|
||||
;;; Version 1.0 (the "NPL"); you may not use this file except in
|
||||
;;; compliance with the NPL. You may obtain a copy of the NPL at
|
||||
;;; http://www.mozilla.org/NPL/
|
||||
;;;
|
||||
;;; Software distributed under the NPL is distributed on an "AS IS" basis,
|
||||
;;; WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
|
||||
;;; for the specific language governing rights and limitations under the
|
||||
;;; NPL.
|
||||
;;;
|
||||
;;; The Initial Developer of this code under the NPL is Netscape
|
||||
;;; Communications Corporation. Portions created by Netscape are
|
||||
;;; Copyright (C) 1998 Netscape Communications Corporation. All Rights
|
||||
;;; Reserved.
|
||||
|
||||
;;;
|
||||
;;; LALR(1) and LR(1) grammar generator
|
||||
;;;
|
||||
;;; Waldemar Horwat (waldemar@netscape.com)
|
||||
;;;
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
|
||||
; kernel-item-alist is a list of pairs (item . prev), where item is a kernel item
|
||||
; and prev is either nil or a laitem. kernel is a list of the kernel items in a canonical order.
|
||||
; Return a new state with the given list of kernel items and state number.
|
||||
; For each non-null prev in kernel-item-alist, update (laitem-propagates prev) to include the
|
||||
; corresponding laitem in the new state.
|
||||
(defun make-state (grammar kernel kernel-item-alist number initial-lookaheads)
|
||||
(let ((laitems nil)
|
||||
(laitems-hash (make-hash-table :test #'eq)))
|
||||
(labels
|
||||
;Create a laitem for this item and add the association item->laitem to the laitems-hash
|
||||
;hash table if it's not there already. Regardless of whether a new laitem was created,
|
||||
;update the laitem's lookaheads to also include the given lookaheads.
|
||||
;If prev is non-null, update (laitem-propagates prev) to include the laitem if it's not
|
||||
;already included there.
|
||||
;If a new laitem was created and its first symbol after the dot exists and is a
|
||||
;nonterminal A, recursively close items A->.rhs corresponding to all rhs's in the
|
||||
;grammar's rule for A.
|
||||
((close-item (item lookaheads prev)
|
||||
(let ((laitem (gethash item laitems-hash)))
|
||||
(if laitem
|
||||
(setf (laitem-lookaheads laitem)
|
||||
(terminalset-union (laitem-lookaheads laitem) lookaheads))
|
||||
(let ((item-next-symbol (item-next-symbol item)))
|
||||
(setq laitem (allocate-laitem grammar item lookaheads))
|
||||
(push laitem laitems)
|
||||
(setf (gethash item laitems-hash) laitem)
|
||||
(when (nonterminal? item-next-symbol)
|
||||
(multiple-value-bind (next-lookaheads epsilon-lookahead)
|
||||
(string-initial-terminals grammar (rest (item-unseen item)))
|
||||
(let ((next-prev (and epsilon-lookahead laitem)))
|
||||
(dolist (production (rule-productions (grammar-rule grammar item-next-symbol)))
|
||||
(close-item (make-item grammar production 0) next-lookaheads next-prev)))))))
|
||||
(when prev
|
||||
(pushnew laitem (laitem-propagates prev))))))
|
||||
|
||||
(dolist (acons kernel-item-alist nil)
|
||||
(let ((item (car acons))
|
||||
(prev (cdr acons)))
|
||||
(close-item item initial-lookaheads prev)))
|
||||
(allocate-state number kernel (nreverse laitems)))))
|
||||
|
||||
|
||||
; f is a function that takes two arguments:
|
||||
; a grammar symbol, and
|
||||
; a list of kernel items in order of increasing item number.
|
||||
; a list of pairs (item . prev), where item is a kernel item and prev is a laitem;
|
||||
; For each possible symbol X that can be shifted while in the given state S, call
|
||||
; f giving it S and the list of items that constitute the kernel of that shift's destination
|
||||
; state. The prev's are the sources of the corresponding shifted items.
|
||||
(defun state-each-shift-item-alist (f state)
|
||||
(let ((shift-symbols-hash (make-hash-table :test *grammar-symbol-=*)))
|
||||
(dolist (source-laitem (state-laitems state))
|
||||
(let* ((source-item (laitem-item source-laitem))
|
||||
(shift-symbol (item-next-symbol source-item)))
|
||||
(when shift-symbol
|
||||
(push (cons (item-next source-item) source-laitem)
|
||||
(gethash shift-symbol shift-symbols-hash)))))
|
||||
;Use dolist/gethash instead of maphash to make state assignments deterministic.
|
||||
(dolist (shift-symbol (sorted-hash-table-keys shift-symbols-hash))
|
||||
(let ((kernel-item-alist (gethash shift-symbol shift-symbols-hash)))
|
||||
(funcall f shift-symbol (sort (mapcar #'car kernel-item-alist) #'< :key #'item-number) kernel-item-alist)))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; LR(1)
|
||||
|
||||
|
||||
; kernel-item-alist should have the same kernel items as state.
|
||||
; Return true if the prev lookaheads in kernel-item-alist are the same as or subsets of
|
||||
; the corresponding lookaheads in the state's kernel laitems.
|
||||
(defun state-subsumes-lookaheads (state kernel-item-alist)
|
||||
(every
|
||||
#'(lambda (acons)
|
||||
(terminalset-<= (laitem-lookaheads (cdr acons))
|
||||
(laitem-lookaheads (state-laitem state (car acons)))))
|
||||
kernel-item-alist))
|
||||
|
||||
|
||||
; kernel-item-alist should have the same kernel items as state.
|
||||
; Return true if the prev lookaheads in kernel-item-alist are weakly compatible
|
||||
; with the lookaheads in the state's kernel laitems.
|
||||
(defun state-weakly-compatible (state kernel-item-alist)
|
||||
(labels
|
||||
((lookahead-weakly-compatible (lookahead1a lookahead1b lookahead2a lookahead2b)
|
||||
(or (and (terminalsets-disjoint lookahead1a lookahead2b)
|
||||
(terminalsets-disjoint lookahead1b lookahead2a))
|
||||
(not (terminalsets-disjoint lookahead1a lookahead1b))
|
||||
(not (terminalsets-disjoint lookahead2a lookahead2b))))
|
||||
|
||||
(lookahead-list-weakly-compatible (lookahead1a lookaheads1 lookahead2a lookaheads2)
|
||||
(or (endp lookaheads1)
|
||||
(and (lookahead-weakly-compatible lookahead1a (first lookaheads1) lookahead2a (first lookaheads2))
|
||||
(lookahead-list-weakly-compatible lookahead1a (rest lookaheads1) lookahead2a (rest lookaheads2)))))
|
||||
|
||||
(lookahead-lists-weakly-compatible (lookaheads1 lookaheads2)
|
||||
(or (endp lookaheads1)
|
||||
(and (lookahead-list-weakly-compatible (first lookaheads1) (rest lookaheads1) (first lookaheads2) (rest lookaheads2))
|
||||
(lookahead-lists-weakly-compatible (rest lookaheads1) (rest lookaheads2))))))
|
||||
|
||||
(or (= (length kernel-item-alist) 1)
|
||||
(lookahead-lists-weakly-compatible
|
||||
(mapcar #'(lambda (acons) (laitem-lookaheads (state-laitem state (car acons)))) kernel-item-alist)
|
||||
(mapcar #'(lambda (acons) (laitem-lookaheads (cdr acons))) kernel-item-alist)))))
|
||||
|
||||
|
||||
; Propagate all lookaheads in the state.
|
||||
(defun propagate-internal-lookaheads (state)
|
||||
(dolist (src-laitem (state-laitems state))
|
||||
(let ((src-lookaheads (laitem-lookaheads src-laitem)))
|
||||
(dolist (dst-laitem (laitem-propagates src-laitem))
|
||||
(setf (laitem-lookaheads dst-laitem)
|
||||
(terminalset-union (laitem-lookaheads dst-laitem) src-lookaheads))))))
|
||||
|
||||
|
||||
; Propagate all lookaheads in kernel-item-alist, which must target destination-state.
|
||||
; Mark destination-state as dirty in the dirty-states hash table.
|
||||
(defun propagate-external-lookaheads (kernel-item-alist destination-state dirty-states)
|
||||
(dolist (acons kernel-item-alist)
|
||||
(let ((dest-laitem (state-laitem destination-state (car acons)))
|
||||
(src-laitem (cdr acons)))
|
||||
(setf (laitem-lookaheads dest-laitem)
|
||||
(terminalset-union (laitem-lookaheads dest-laitem) (laitem-lookaheads src-laitem)))))
|
||||
(setf (gethash destination-state dirty-states) t))
|
||||
|
||||
|
||||
; Make all states in the grammar and return the initial state.
|
||||
; Initialize the grammar's list of states.
|
||||
; Set up the laitems' propagate lists but do not propagate lookaheads yet.
|
||||
; Initialize the states' gotos lists.
|
||||
; Initialize the states' shift (but not reduce or accept) transitions in the transitions lists.
|
||||
(defun add-all-lr-states (grammar)
|
||||
(let* ((initial-item (make-item grammar (grammar-start-production grammar) 0))
|
||||
(lr-states-hash (make-hash-table :test #'equal)) ;kernel -> list of states with that kernel
|
||||
(initial-kernel (list initial-item))
|
||||
(initial-state (make-state grammar initial-kernel (list (cons initial-item nil)) 0 (make-terminalset grammar *end-marker*)))
|
||||
(states (list initial-state))
|
||||
(next-state-number 1))
|
||||
(setf (gethash initial-kernel lr-states-hash) (list initial-state))
|
||||
(do ((source-states (list initial-state))
|
||||
(dirty-states (make-hash-table :test #'eq))) ;Set of states whose kernel lookaheads changed and haven't been propagated yet
|
||||
((and (endp source-states) (zerop (hash-table-count dirty-states))))
|
||||
(labels
|
||||
((make-destination-state (kernel kernel-item-alist)
|
||||
(let* ((possible-destination-states (gethash kernel lr-states-hash))
|
||||
(destination-state (find-if #'(lambda (possible-destination-state)
|
||||
(state-subsumes-lookaheads possible-destination-state kernel-item-alist))
|
||||
possible-destination-states)))
|
||||
(cond
|
||||
(destination-state)
|
||||
((setq destination-state (find-if #'(lambda (possible-destination-state)
|
||||
(state-weakly-compatible possible-destination-state kernel-item-alist))
|
||||
possible-destination-states))
|
||||
(propagate-external-lookaheads kernel-item-alist destination-state dirty-states))
|
||||
(t
|
||||
(setq destination-state (make-state grammar kernel kernel-item-alist next-state-number *empty-terminalset*))
|
||||
(propagate-external-lookaheads kernel-item-alist destination-state dirty-states)
|
||||
(push destination-state (gethash kernel lr-states-hash))
|
||||
(incf next-state-number)
|
||||
(push destination-state states)
|
||||
(push destination-state source-states)))
|
||||
destination-state))
|
||||
|
||||
(update-destination-state (destination-state kernel-item-alist)
|
||||
(cond
|
||||
((state-subsumes-lookaheads destination-state kernel-item-alist)
|
||||
destination-state)
|
||||
((state-weakly-compatible destination-state kernel-item-alist)
|
||||
(propagate-external-lookaheads kernel-item-alist destination-state dirty-states)
|
||||
destination-state)
|
||||
(t (make-destination-state (state-kernel destination-state) kernel-item-alist)))))
|
||||
|
||||
(if source-states
|
||||
(let ((source-state (pop source-states)))
|
||||
(remhash source-state dirty-states)
|
||||
(propagate-internal-lookaheads source-state)
|
||||
(state-each-shift-item-alist
|
||||
#'(lambda (shift-symbol kernel kernel-item-alist)
|
||||
(let ((destination-state (make-destination-state kernel kernel-item-alist)))
|
||||
(if (nonterminal? shift-symbol)
|
||||
(push (cons shift-symbol destination-state)
|
||||
(state-gotos source-state))
|
||||
(push (cons shift-symbol (make-shift-transition destination-state))
|
||||
(state-transitions source-state)))))
|
||||
source-state))
|
||||
(dolist (dirty-state (sort (hash-table-keys dirty-states) #'< :key #'state-number))
|
||||
(when (remhash dirty-state dirty-states)
|
||||
(propagate-internal-lookaheads dirty-state)
|
||||
(state-each-shift-item-alist
|
||||
#'(lambda (shift-symbol kernel kernel-item-alist)
|
||||
(declare (ignore kernel))
|
||||
(if (nonterminal? shift-symbol)
|
||||
(let* ((destination-binding (assoc shift-symbol (state-gotos dirty-state) :test *grammar-symbol-=*))
|
||||
(destination-state (assert-non-null (cdr destination-binding))))
|
||||
(setf (cdr destination-binding) (update-destination-state destination-state kernel-item-alist)))
|
||||
(let* ((destination-transition (cdr (assoc shift-symbol (state-transitions dirty-state) :test *grammar-symbol-=*)))
|
||||
(destination-state (assert-non-null (transition-state destination-transition))))
|
||||
(setf (transition-state destination-transition)
|
||||
(update-destination-state destination-state kernel-item-alist)))))
|
||||
dirty-state))))))
|
||||
(setf (grammar-states grammar) (nreverse states))
|
||||
initial-state))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; LALR(1)
|
||||
|
||||
|
||||
; Make all states in the grammar and return the initial state.
|
||||
; Initialize the grammar's list of states.
|
||||
; Set up the laitems' propagate lists but do not propagate lookaheads yet.
|
||||
; Initialize the states' gotos lists.
|
||||
; Initialize the states' shift (but not reduce or accept) transitions in the transitions lists.
|
||||
(defun add-all-lalr-states (grammar)
|
||||
(let* ((initial-item (make-item grammar (grammar-start-production grammar) 0))
|
||||
(lalr-states-hash (make-hash-table :test #'equal)) ;kernel -> state
|
||||
(initial-kernel (list initial-item))
|
||||
(initial-state (make-state grammar initial-kernel (list (cons initial-item nil)) 0 (make-terminalset grammar *end-marker*)))
|
||||
(states (list initial-state))
|
||||
(next-state-number 1))
|
||||
(setf (gethash initial-kernel lalr-states-hash) initial-state)
|
||||
(do ((source-states (list initial-state)))
|
||||
((endp source-states))
|
||||
(let ((source-state (pop source-states)))
|
||||
(state-each-shift-item-alist
|
||||
#'(lambda (shift-symbol kernel kernel-item-alist)
|
||||
(let ((destination-state (gethash kernel lalr-states-hash)))
|
||||
(if destination-state
|
||||
(dolist (acons kernel-item-alist)
|
||||
(pushnew (state-laitem destination-state (car acons)) (laitem-propagates (cdr acons))))
|
||||
(progn
|
||||
(setq destination-state (make-state grammar kernel kernel-item-alist next-state-number *empty-terminalset*))
|
||||
(setf (gethash kernel lalr-states-hash) destination-state)
|
||||
(incf next-state-number)
|
||||
(push destination-state states)
|
||||
(push destination-state source-states)))
|
||||
(if (nonterminal? shift-symbol)
|
||||
(push (cons shift-symbol destination-state)
|
||||
(state-gotos source-state))
|
||||
(push (cons shift-symbol (make-shift-transition destination-state))
|
||||
(state-transitions source-state)))))
|
||||
source-state)))
|
||||
(setf (grammar-states grammar) (nreverse states))
|
||||
initial-state))
|
||||
|
||||
|
||||
; Propagate the lookaheads in the LALR(1) grammar.
|
||||
(defun propagate-lalr-lookaheads (grammar)
|
||||
(let ((dirty-laitems (make-hash-table :test #'eq)))
|
||||
(dolist (state (grammar-states grammar))
|
||||
(dolist (laitem (state-laitems state))
|
||||
(when (and (laitem-propagates laitem) (not (terminalset-empty? (laitem-lookaheads laitem))))
|
||||
(setf (gethash laitem dirty-laitems) t))))
|
||||
(do ()
|
||||
((zerop (hash-table-count dirty-laitems)))
|
||||
(dolist (dirty-laitem (hash-table-keys dirty-laitems))
|
||||
(remhash dirty-laitem dirty-laitems)
|
||||
(let ((src-lookaheads (laitem-lookaheads dirty-laitem)))
|
||||
(dolist (dst-laitem (laitem-propagates dirty-laitem))
|
||||
(let* ((old-dst-lookaheads (laitem-lookaheads dst-laitem))
|
||||
(new-dst-lookaheads (terminalset-union old-dst-lookaheads src-lookaheads)))
|
||||
(unless (terminalset-= old-dst-lookaheads new-dst-lookaheads)
|
||||
(setf (laitem-lookaheads dst-laitem) new-dst-lookaheads)
|
||||
(setf (gethash dst-laitem dirty-laitems) t)))))))
|
||||
|
||||
;Erase the propagates chains in all laitems.
|
||||
(dolist (state (grammar-states grammar))
|
||||
(dolist (laitem (state-laitems state))
|
||||
(setf (laitem-propagates laitem) nil)))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
|
||||
|
||||
; Calculate the reduce and accept transitions in the grammar.
|
||||
; Also sort all transitions by their terminal numbers and gotos by their nonterminal numbers.
|
||||
; Conflicting transitions are sorted as follows:
|
||||
; shifts come before reduces and accepts
|
||||
; accepts come before reduces
|
||||
; reduces with lower production numbers come before reduces with higher production numbers
|
||||
; Disambiguation will choose the first member of a sorted list of conflicting transitions.
|
||||
(defun finish-transitions (grammar)
|
||||
(dolist (state (grammar-states grammar))
|
||||
(dolist (laitem (state-laitems state))
|
||||
(let ((item (laitem-item laitem)))
|
||||
(unless (item-next-symbol item)
|
||||
(if (grammar-symbol-= (item-lhs item) *start-nonterminal*)
|
||||
(when (terminal-in-terminalset grammar *end-marker* (laitem-lookaheads laitem))
|
||||
(push (cons *end-marker* (make-accept-transition))
|
||||
(state-transitions state)))
|
||||
(map-terminalset-reverse
|
||||
#'(lambda (lookahead)
|
||||
(push (cons lookahead (make-reduce-transition (item-production item)))
|
||||
(state-transitions state)))
|
||||
grammar
|
||||
(laitem-lookaheads laitem))))))
|
||||
(setf (state-gotos state)
|
||||
(sort (state-gotos state) #'< :key #'(lambda (goto-cons) (state-number (cdr goto-cons)))))
|
||||
(setf (state-transitions state)
|
||||
(sort (state-transitions state)
|
||||
#'(lambda (transition-cons-1 transition-cons-2)
|
||||
(let ((terminal-number-1 (terminal-number grammar (car transition-cons-1)))
|
||||
(terminal-number-2 (terminal-number grammar (car transition-cons-2))))
|
||||
(cond
|
||||
((< terminal-number-1 terminal-number-2) t)
|
||||
((> terminal-number-1 terminal-number-2) nil)
|
||||
(t (let* ((transition1 (cdr transition-cons-1))
|
||||
(transition2 (cdr transition-cons-2))
|
||||
(transition-kind-1 (transition-kind transition1))
|
||||
(transition-kind-2 (transition-kind transition2)))
|
||||
(cond
|
||||
((eq transition-kind-2 :shift) nil)
|
||||
((eq transition-kind-1 :shift) t)
|
||||
((eq transition-kind-2 :accept) nil)
|
||||
((eq transition-kind-1 :accept) t)
|
||||
(t (let ((production-number-1 (production-number (transition-production transition1)))
|
||||
(production-number-2 (production-number (transition-production transition2))))
|
||||
(< production-number-1 production-number-2)))))))))))))
|
||||
|
||||
|
||||
; Find ambiguities, if any, in the grammar. Report them on the given stream.
|
||||
; Fix all ambiguities in favor of the first transition listed
|
||||
; (the transitions were ordered by finish-transitions).
|
||||
(defun report-and-fix-ambiguities (grammar stream)
|
||||
(let ((found-ambiguities nil))
|
||||
(pprint-logical-block (stream nil)
|
||||
(dolist (state (grammar-states grammar))
|
||||
(labels
|
||||
|
||||
((report-ambiguity (transition-cons other-transition-conses)
|
||||
(unless found-ambiguities
|
||||
(setq found-ambiguities t)
|
||||
(format stream "~&Ambiguities:")
|
||||
(pprint-indent :block 2 stream))
|
||||
(pprint-newline :mandatory stream)
|
||||
(pprint-logical-block (stream nil)
|
||||
(format stream "S~D: ~W ~:_=> ~:_" (state-number state) (car transition-cons))
|
||||
(pprint-logical-block (stream nil)
|
||||
(dolist (a (cons transition-cons other-transition-conses))
|
||||
(print-transition (cdr a) stream)
|
||||
(format stream " ~:_")))))
|
||||
|
||||
; Check the list of transition-conses and report ambiguities.
|
||||
; start is the start of a possibly larger list of transition-conses whose tail
|
||||
; is the given list. If ambiguities exist, return a copy of start up to the
|
||||
; position of list in it followed by list with ambiguities removed. If not,
|
||||
; return start unchanged.
|
||||
(check (transition-conses start)
|
||||
(if transition-conses
|
||||
(let* ((transition-cons (first transition-conses))
|
||||
(transition-terminal (car transition-cons))
|
||||
(transition-conses-rest (rest transition-conses)))
|
||||
(if transition-conses-rest
|
||||
(if (grammar-symbol-= transition-terminal (car (first transition-conses-rest)))
|
||||
(let ((unrelated-transitions
|
||||
(member-if #'(lambda (a) (not (grammar-symbol-= transition-terminal (car a))))
|
||||
transition-conses-rest)))
|
||||
(report-ambiguity transition-cons (ldiff transition-conses-rest unrelated-transitions))
|
||||
(check unrelated-transitions (append (ldiff start transition-conses-rest) unrelated-transitions)))
|
||||
(check transition-conses-rest start))
|
||||
start))
|
||||
start)))
|
||||
|
||||
(let ((transition-conses (state-transitions state)))
|
||||
(setf (state-transitions state) (check transition-conses transition-conses))))))
|
||||
(when found-ambiguities
|
||||
(pprint-newline :mandatory stream))))
|
||||
|
||||
|
||||
; Erase the existing parser, if any, for the given grammar.
|
||||
(defun clear-parser (grammar)
|
||||
(clrhash (grammar-items-hash grammar))
|
||||
(setf (grammar-states grammar) nil))
|
||||
|
||||
|
||||
; Construct a LR or LALR parser in the given grammar. kind should be either :lalr-1 or :lr-1.
|
||||
; Return the grammar.
|
||||
(defun compile-parser (grammar kind)
|
||||
(clear-parser grammar)
|
||||
(ecase kind
|
||||
(:lalr-1
|
||||
(add-all-lalr-states grammar)
|
||||
(propagate-lalr-lookaheads grammar))
|
||||
(:lr-1
|
||||
(add-all-lr-states grammar)))
|
||||
(finish-transitions grammar)
|
||||
(report-and-fix-ambiguities grammar *error-output*)
|
||||
grammar)
|
||||
|
||||
|
||||
; Make the grammar and compile its parser. kind should be either :lalr-1 or :lr-1.
|
||||
(defun make-and-compile-grammar (kind parametrization start-symbol grammar-source)
|
||||
(compile-parser (make-grammar parametrization start-symbol grammar-source)
|
||||
kind))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
|
||||
; Parse the input list of tokens to produce a parse tree.
|
||||
; token-terminal is a function that returns a terminal symbol when given an input token.
|
||||
(defun parse (grammar token-terminal input)
|
||||
(labels
|
||||
(;Continue the parse with the given parser stack and remainder of input.
|
||||
(parse-step (stack input)
|
||||
(if (endp input)
|
||||
(parse-step-1 stack *end-marker* nil nil)
|
||||
(let ((token (first input)))
|
||||
(parse-step-1 stack (funcall token-terminal token) token (rest input)))))
|
||||
|
||||
;Same as parse-step except that the next input terminal has been determined already.
|
||||
;input-rest contains the input tokens after the next token.
|
||||
(parse-step-1 (stack terminal token input-rest)
|
||||
(let* ((state (caar stack))
|
||||
(transition (cdr (assoc terminal (state-transitions state) :test *grammar-symbol-=*))))
|
||||
(if transition
|
||||
(case (transition-kind transition)
|
||||
(:shift (parse-step (acons (transition-state transition) token stack) input-rest))
|
||||
(:reduce (let ((production (transition-production transition))
|
||||
(expansion nil))
|
||||
(dotimes (i (production-rhs-length production))
|
||||
(push (cdr (pop stack)) expansion))
|
||||
(let* ((state (caar stack))
|
||||
(dst-state (assert-non-null
|
||||
(cdr (assoc (production-lhs production) (state-gotos state) :test *grammar-symbol-=*))))
|
||||
(named-expansion (cons (production-name production) expansion)))
|
||||
(parse-step-1 (acons dst-state named-expansion stack) terminal token input-rest))))
|
||||
(:accept (cdar stack))
|
||||
(t (error "Bad transition: ~S" transition)))
|
||||
(error "Parse error on ~S followed by ~S ..." token (ldiff input-rest (nthcdr 10 input-rest)))))))
|
||||
|
||||
(parse-step (list (cons (grammar-start-state grammar) nil)) input)))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; ACTIONS
|
||||
|
||||
; Initialize the action-signatures hash table, setting each grammar symbol's signature
|
||||
; to null for now. Also clear all production actions in the grammar.
|
||||
(defun clear-actions (grammar)
|
||||
(let ((action-signatures (make-hash-table :test *grammar-symbol-=*))
|
||||
(terminals (grammar-terminals grammar))
|
||||
(nonterminals (grammar-nonterminals grammar)))
|
||||
(dotimes (i (length terminals))
|
||||
(setf (gethash (svref terminals i) action-signatures) nil))
|
||||
(dotimes (i (length nonterminals))
|
||||
(setf (gethash (svref nonterminals i) action-signatures) nil))
|
||||
(setf (grammar-action-signatures grammar) action-signatures)
|
||||
(each-grammar-production
|
||||
grammar
|
||||
#'(lambda (production)
|
||||
(setf (production-actions production) nil)
|
||||
(setf (production-n-action-args production) nil)
|
||||
(setf (production-evaluator-code production) nil)
|
||||
(setf (production-evaluator production) nil)))
|
||||
(clrhash (grammar-terminal-actions grammar))))
|
||||
|
||||
|
||||
; Declare the type of action action-symbol, when called on general-grammar-symbol, to be type-expr.
|
||||
; Signal an error on duplicate actions.
|
||||
; It's OK if some of the symbol instances don't exist, as long as at least one does.
|
||||
(defun declare-action (grammar general-grammar-symbol action-symbol type-expr)
|
||||
(unless (and action-symbol (symbolp action-symbol))
|
||||
(error "Bad action name ~S" action-symbol))
|
||||
(let ((action-signatures (grammar-action-signatures grammar))
|
||||
(grammar-symbols (general-grammar-symbol-instances grammar general-grammar-symbol))
|
||||
(symbol-exists nil))
|
||||
(dolist (grammar-symbol grammar-symbols)
|
||||
(let ((signature (gethash grammar-symbol action-signatures :undefined)))
|
||||
(unless (eq signature :undefined)
|
||||
(setq symbol-exists t)
|
||||
(when (assoc action-symbol signature :test #'eq)
|
||||
(error "Attempt to redefine the type of action ~S on ~S" action-symbol grammar-symbol))
|
||||
(setf (gethash grammar-symbol action-signatures)
|
||||
(nconc signature (list (cons action-symbol type-expr))))
|
||||
(if (nonterminal? grammar-symbol)
|
||||
(dolist (production (rule-productions (grammar-rule grammar grammar-symbol)))
|
||||
(setf (production-actions production)
|
||||
(nconc (production-actions production) (list (cons action-symbol nil)))))
|
||||
(let ((terminal-actions (grammar-terminal-actions grammar)))
|
||||
(assert-type grammar-symbol terminal)
|
||||
(setf (gethash grammar-symbol terminal-actions)
|
||||
(nconc (gethash grammar-symbol terminal-actions) (list (cons action-symbol nil)))))))))
|
||||
(unless symbol-exists
|
||||
(error "Bad action grammar symbol ~S" grammar-symbols))))
|
||||
|
||||
|
||||
; Return the list of pairs (action-symbol . type-or-type-expr) for this grammar-symbol.
|
||||
; The pairs are in order from oldest to newest action-symbols added to this grammar-symbol.
|
||||
(declaim (inline grammar-symbol-signature))
|
||||
(defun grammar-symbol-signature (grammar grammar-symbol)
|
||||
(gethash grammar-symbol (grammar-action-signatures grammar)))
|
||||
|
||||
|
||||
; Return the list of action types of the grammar's user start-symbol.
|
||||
(defun grammar-user-start-action-types (grammar)
|
||||
(mapcar #'cdr (grammar-symbol-signature grammar (gramar-user-start-symbol grammar))))
|
||||
|
||||
|
||||
; If action action-symbol is declared on grammar-symbol, return two values:
|
||||
; t, and
|
||||
; the action's type-expr;
|
||||
; If not, return nil.
|
||||
(defun action-declaration (grammar grammar-symbol action-symbol)
|
||||
(let ((declaration (assoc action-symbol (grammar-symbol-signature grammar grammar-symbol) :test #'eq)))
|
||||
(and declaration
|
||||
(values t (cdr declaration)))))
|
||||
|
||||
|
||||
; Call f on every action declaration, passing it two arguments:
|
||||
; the grammar-symbol;
|
||||
; a pair (action-symbol . type-expr).
|
||||
; f may modify the action's type-expr.
|
||||
(defun each-action-declaration (grammar f)
|
||||
(maphash #'(lambda (grammar-symbol signature)
|
||||
(dolist (action-declaration signature)
|
||||
(funcall f grammar-symbol action-declaration)))
|
||||
(grammar-action-signatures grammar)))
|
||||
|
||||
|
||||
; Define action action-symbol, when called on the production with the given name,
|
||||
; to be action-expr. The action should have been declared already.
|
||||
(defun define-action (grammar production-name action-symbol action-expr)
|
||||
(dolist (production (general-production-productions (grammar-general-production grammar production-name)))
|
||||
(let ((definition (assoc action-symbol (production-actions production) :test #'eq)))
|
||||
(cond
|
||||
((null definition)
|
||||
(error "Attempt to define action ~S on ~S, which hasn't been declared yet" action-symbol production-name))
|
||||
((cdr definition)
|
||||
(error "Duplicate definition of action ~S on ~S" action-symbol production-name))
|
||||
(t (setf (cdr definition) (make-action action-expr)))))))
|
||||
|
||||
|
||||
; Define action action-symbol, when called on the given terminal,
|
||||
; to execute the given function, which should take a token as an input and
|
||||
; produce a value of the proper type as output.
|
||||
; The action should have been declared already.
|
||||
(defun define-terminal-action (grammar terminal action-symbol action-function)
|
||||
(assert-type action-function function)
|
||||
(let ((definition (assoc action-symbol (gethash terminal (grammar-terminal-actions grammar)) :test #'eq)))
|
||||
(cond
|
||||
((null definition)
|
||||
(error "Attempt to define action ~S on ~S, which hasn't been declared yet" action-symbol terminal))
|
||||
((cdr definition)
|
||||
(error "Duplicate definition of action ~S on ~S" action-symbol terminal))
|
||||
(t (setf (cdr definition) action-function)))))
|
||||
|
||||
|
||||
|
||||
; Parse the input list of tokens to produce a list of action results.
|
||||
; token-terminal is a function that returns a terminal symbol when given an input token.
|
||||
; If trace is:
|
||||
; nil, don't print trace information
|
||||
; :code, print trace information, including action code
|
||||
; other print trace information
|
||||
; Return two values:
|
||||
; the list of action results;
|
||||
; the list of action results' types.
|
||||
(defun action-parse (grammar token-terminal input &key trace)
|
||||
(labels
|
||||
(;Continue the parse with the given stacks and remainder of input.
|
||||
(parse-step (state-stack value-stack input)
|
||||
(if (endp input)
|
||||
(parse-step-1 state-stack value-stack *end-marker* nil nil)
|
||||
(let ((token (first input)))
|
||||
(parse-step-1 state-stack value-stack (funcall token-terminal token) token (rest input)))))
|
||||
|
||||
;Same as parse-step except that the next input terminal has been determined already.
|
||||
;input-rest contains the input tokens after the next token.
|
||||
(parse-step-1 (state-stack value-stack terminal token input-rest)
|
||||
(let* ((state (car state-stack))
|
||||
(transition (cdr (assoc terminal (state-transitions state) :test *grammar-symbol-=*))))
|
||||
(if transition
|
||||
(case (transition-kind transition)
|
||||
(:shift
|
||||
(dolist (action-function-binding (gethash terminal (grammar-terminal-actions grammar)))
|
||||
(push (funcall (cdr action-function-binding) token) value-stack))
|
||||
(parse-step (cons (transition-state transition) state-stack) value-stack input-rest))
|
||||
(:reduce
|
||||
(let* ((production (transition-production transition))
|
||||
(state-stack (nthcdr (production-rhs-length production) state-stack))
|
||||
(state (car state-stack))
|
||||
(dst-state (assert-non-null
|
||||
(cdr (assoc (production-lhs production) (state-gotos state) :test *grammar-symbol-=*))))
|
||||
(value-stack (funcall (production-evaluator production) value-stack)))
|
||||
(parse-step-1 (cons dst-state state-stack) value-stack terminal token input-rest)))
|
||||
(:accept (values (nreverse value-stack) (grammar-user-start-action-types grammar)))
|
||||
(t (error "Bad transition: ~S" transition)))
|
||||
(error "Parse error on ~S followed by ~S ..." token (ldiff input-rest (nthcdr 10 input-rest)))))))
|
||||
|
||||
(if trace
|
||||
(trace-action-parse grammar token-terminal input trace)
|
||||
(parse-step (list (grammar-start-state grammar)) nil input))))
|
||||
|
||||
|
||||
; Same as action-parse, but with tracing information
|
||||
; If trace is:
|
||||
; :code, print trace information, including action code
|
||||
; other print trace information
|
||||
; Return two values:
|
||||
; the list of action results;
|
||||
; the list of action results' types.
|
||||
(defun trace-action-parse (grammar token-terminal input trace)
|
||||
(labels
|
||||
(;Continue the parse with the given stacks and remainder of input.
|
||||
;type-stack contains the types of corresponding value-stack entries.
|
||||
(parse-step (state-stack value-stack type-stack input)
|
||||
(if (endp input)
|
||||
(parse-step-1 state-stack value-stack type-stack *end-marker* nil nil)
|
||||
(let ((token (first input)))
|
||||
(parse-step-1 state-stack value-stack type-stack (funcall token-terminal token) token (rest input)))))
|
||||
|
||||
;Same as parse-step except that the next input terminal has been determined already.
|
||||
;input-rest contains the input tokens after the next token.
|
||||
(parse-step-1 (state-stack value-stack type-stack terminal token input-rest)
|
||||
(let* ((state (car state-stack))
|
||||
(transition (cdr (assoc terminal (state-transitions state) :test *grammar-symbol-=*))))
|
||||
(format *trace-output* "S~D: ~@_" (state-number state))
|
||||
(print-values (reverse value-stack) (reverse type-stack) *trace-output*)
|
||||
(pprint-newline :mandatory *trace-output*)
|
||||
(if transition
|
||||
(case (transition-kind transition)
|
||||
(:shift
|
||||
(format *trace-output* " shift ~W~:@_" terminal)
|
||||
(dolist (action-function-binding (gethash terminal (grammar-terminal-actions grammar)))
|
||||
(push (funcall (cdr action-function-binding) token) value-stack))
|
||||
(dolist (action-signature (grammar-symbol-signature grammar terminal))
|
||||
(push (cdr action-signature) type-stack))
|
||||
(parse-step (cons (transition-state transition) state-stack) value-stack type-stack input-rest))
|
||||
(:reduce
|
||||
(let ((production (transition-production transition)))
|
||||
(write-string " reduce " *trace-output*)
|
||||
(if (eq trace :code)
|
||||
(write production :stream *trace-output* :pretty t)
|
||||
(print-production production *trace-output*))
|
||||
(pprint-newline :mandatory *trace-output*)
|
||||
(let* ((state-stack (nthcdr (production-rhs-length production) state-stack))
|
||||
(state (car state-stack))
|
||||
(dst-state (assert-non-null
|
||||
(cdr (assoc (production-lhs production) (state-gotos state) :test *grammar-symbol-=*))))
|
||||
(value-stack (funcall (production-evaluator production) value-stack))
|
||||
(type-stack (nthcdr (production-n-action-args production) type-stack)))
|
||||
(dolist (action-signature (grammar-symbol-signature grammar (production-lhs production)))
|
||||
(push (cdr action-signature) type-stack))
|
||||
(parse-step-1 (cons dst-state state-stack) value-stack type-stack terminal token input-rest))))
|
||||
(:accept
|
||||
(format *trace-output* " accept~:@_")
|
||||
(values (nreverse value-stack) (nreverse type-stack)))
|
||||
(t (error "Bad transition: ~S" transition)))
|
||||
(error "Parse error on ~S followed by ~S ..." token (ldiff input-rest (nthcdr 10 input-rest)))))))
|
||||
|
||||
(parse-step (list (grammar-start-state grammar)) nil nil input)))
|
||||
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
js/semantics contains experimental code used to generate LR(1) and LALR(1)
|
||||
grammars for JavaScript as well as compile and check formal semantics for
|
||||
JavaScript. The semantics can be executed directly or printed into either
|
||||
HTML or Microsoft Word RTF formats.
|
||||
|
||||
This code is written in standard Common Lisp. It's been used under Macintosh
|
||||
Common Lisp 4.0, but should also work under other Common Lisp implementations.
|
||||
|
||||
Contact Waldemar Horwat (waldemar@netscape.com or waldemar@acm.org) for
|
||||
more information.
|
||||
|
|
@ -0,0 +1,699 @@
|
|||
;;; The contents of this file are subject to the Netscape Public License
|
||||
;;; Version 1.0 (the "NPL"); you may not use this file except in
|
||||
;;; compliance with the NPL. You may obtain a copy of the NPL at
|
||||
;;; http://www.mozilla.org/NPL/
|
||||
;;;
|
||||
;;; Software distributed under the NPL is distributed on an "AS IS" basis,
|
||||
;;; WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
|
||||
;;; for the specific language governing rights and limitations under the
|
||||
;;; NPL.
|
||||
;;;
|
||||
;;; The Initial Developer of this code under the NPL is Netscape
|
||||
;;; Communications Corporation. Portions created by Netscape are
|
||||
;;; Copyright (C) 1998 Netscape Communications Corporation. All Rights
|
||||
;;; Reserved.
|
||||
|
||||
;;;
|
||||
;;; RTF reader and writer
|
||||
;;;
|
||||
;;; Waldemar Horwat (waldemar@netscape.com)
|
||||
;;;
|
||||
|
||||
|
||||
;;; 1440 twips/inch
|
||||
;;; 20 twips/pt
|
||||
|
||||
(defparameter *rtf-definitions*
|
||||
'((:rtf-intro rtf 1 mac ansicpg 10000 uc 1 deff 0 deflang 2057 deflangfe 2057)
|
||||
|
||||
;Fonts
|
||||
((+ :rtf-intro) :fonttbl)
|
||||
(:fonttbl (fonttbl :fonts))
|
||||
|
||||
(:times f 0)
|
||||
((+ :fonts) (:times froman fcharset 256 fprq 2 (* panose "02020603050405020304") "Times New Roman;"))
|
||||
(:symbol f 3)
|
||||
((+ :fonts) (:symbol ftech fcharset 2 fprq 2 "Symbol;"))
|
||||
(:helvetica f 4)
|
||||
((+ :fonts) (:helvetica fnil fcharset 256 fprq 2 "Helvetica;"))
|
||||
(:courier f 5)
|
||||
((+ :fonts) (:courier fmodern fcharset 256 fprq 2 "Courier New;"))
|
||||
(:palatino f 6)
|
||||
((+ :fonts) (:palatino fnil fcharset 256 fprq 2 "Palatino;"))
|
||||
(:zapf-chancery f 7)
|
||||
((+ :fonts) (:zapf-chancery fscript fcharset 256 fprq 2 "Zapf Chancery;"))
|
||||
(:zapf-dingbats f 8)
|
||||
((+ :fonts) (:zapf-dingbats ftech fcharset 2 fprq 2 "Zapf Dingbats;"))
|
||||
|
||||
|
||||
;Color table
|
||||
((+ :rtf-intro) :colortbl)
|
||||
(:colortbl (colortbl ";" ;0
|
||||
red 0 green 0 blue 0 ";" ;1
|
||||
red 0 green 0 blue 255 ";" ;2
|
||||
red 0 green 255 blue 255 ";" ;3
|
||||
red 0 green 255 blue 0 ";" ;4
|
||||
red 255 green 0 blue 255 ";" ;5
|
||||
red 255 green 0 blue 0 ";" ;6
|
||||
red 255 green 255 blue 0 ";" ;7
|
||||
red 255 green 255 blue 255 ";" ;8
|
||||
red 0 green 0 blue 128 ";" ;9
|
||||
red 0 green 128 blue 128 ";" ;10
|
||||
red 0 green 128 blue 0 ";" ;11
|
||||
red 128 green 0 blue 128 ";" ;12
|
||||
red 128 green 0 blue 0 ";" ;13
|
||||
red 128 green 128 blue 0 ";" ;14
|
||||
red 128 green 128 blue 128 ";" ;15
|
||||
red 192 green 192 blue 192 ";")) ;16
|
||||
(:black cf 1)
|
||||
(:blue cf 2)
|
||||
(:turquoise cf 3)
|
||||
(:bright-green cf 4)
|
||||
(:pink cf 5)
|
||||
(:red cf 6)
|
||||
(:yellow cf 7)
|
||||
(:white cf 8)
|
||||
(:dark-blue cf 9)
|
||||
(:teal cf 10)
|
||||
(:green cf 11)
|
||||
(:violet cf 12)
|
||||
(:dark-red cf 13)
|
||||
(:dark-yellow cf 14)
|
||||
(:gray-50 cf 15)
|
||||
(:gray-25 cf 16)
|
||||
|
||||
|
||||
;Misc.
|
||||
(:tab2 tab)
|
||||
(:tab3 tab)
|
||||
(:8-pt fs 16)
|
||||
(:9-pt fs 18)
|
||||
(:10-pt fs 20)
|
||||
(:12-pt fs 24)
|
||||
(:no-language lang 1024)
|
||||
(:english lang 1033)
|
||||
(:english-uk lang 2057)
|
||||
|
||||
(:reset-section sectd)
|
||||
(:new-section sect)
|
||||
(:reset-paragraph pard plain)
|
||||
((:new-paragraph t) par)
|
||||
((:new-line t) line)
|
||||
|
||||
;Symbols (-10 suffix means 10-point, etc.)
|
||||
((:bullet 1) bullet)
|
||||
((:minus 1) endash)
|
||||
((:not-equal 1) u 8800 \' 173)
|
||||
((:less-or-equal 1) u 8804 \' 178)
|
||||
((:greater-or-equal 1) u 8805 \' 179)
|
||||
((:infinity 1) u 8734 \' 176)
|
||||
((:left-single-quote 1) lquote)
|
||||
((:right-single-quote 1) rquote)
|
||||
((:left-double-quote 1) ldblquote)
|
||||
((:right-double-quote 1) rdblquote)
|
||||
((:left-angle-quote 1) u 171 \' 199)
|
||||
((:right-angle-quote 1) u 187 \' 200)
|
||||
((:bottom-10 1) (field (* fldinst "SYMBOL 94 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((: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)))
|
||||
((:member-10 2) (field (* fldinst "SYMBOL 206 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:derives-10 2) (field (* fldinst "SYMBOL 222 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:left-triangle-bracket-10 1) (field (* fldinst "SYMBOL 225 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:right-triangle-bracket-10 1) (field (* fldinst "SYMBOL 241 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:big-plus-10 2) (field (* fldinst "SYMBOL 58 \\f \"Zapf Dingbats\" \\s 10") (fldrslt :zapf-dingbats :10-pt)))
|
||||
|
||||
((:alpha 1) (field (* fldinst "SYMBOL 97 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:beta 1) (field (* fldinst "SYMBOL 98 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:chi 1) (field (* fldinst "SYMBOL 99 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:delta 1) (field (* fldinst "SYMBOL 100 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:epsilon 1) (field (* fldinst "SYMBOL 101 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:phi 1) (field (* fldinst "SYMBOL 102 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:gamma 1) (field (* fldinst "SYMBOL 103 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:eta 1) (field (* fldinst "SYMBOL 104 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:iota 1) (field (* fldinst "SYMBOL 105 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:kappa 1) (field (* fldinst "SYMBOL 107 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:lambda 1) (field (* fldinst "SYMBOL 108 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:mu 1) (field (* fldinst "SYMBOL 109 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:nu 1) (field (* fldinst "SYMBOL 110 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:omicron 1) (field (* fldinst "SYMBOL 111 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:pi 1) (field (* fldinst "SYMBOL 112 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:theta 1) (field (* fldinst "SYMBOL 113 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:rho 1) (field (* fldinst "SYMBOL 114 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:sigma 1) (field (* fldinst "SYMBOL 115 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:tau 1) (field (* fldinst "SYMBOL 116 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:upsilon 1) (field (* fldinst "SYMBOL 117 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:omega 1) (field (* fldinst "SYMBOL 119 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:xi 1) (field (* fldinst "SYMBOL 120 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:psi 1) (field (* fldinst "SYMBOL 121 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:zeta 1) (field (* fldinst "SYMBOL 122 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
|
||||
|
||||
;Styles
|
||||
((+ :rtf-intro) :stylesheet)
|
||||
(:stylesheet (stylesheet :styles))
|
||||
|
||||
(:normal-num 0)
|
||||
(:normal s :normal-num)
|
||||
((+ :styles) (widctlpar :10-pt :english-uk snext :normal-num "Normal;"))
|
||||
|
||||
(:body-text-num 1)
|
||||
(:body-text s :body-text-num qj sa 120 widctlpar :10-pt :english-uk)
|
||||
((+ :styles) (:body-text sbasedon :normal-num snext :body-text-num "Body Text;"))
|
||||
|
||||
(:section-heading-num 2)
|
||||
(:section-heading s :section-heading-num sa 60 keep keepn nowidctlpar hyphpar 0 level 3 b :12-pt :english-uk)
|
||||
((+ :styles) (:section-heading sbasedon :subsection-heading-num snext :body-text-num "heading 3;"))
|
||||
|
||||
(:subsection-heading-num 3)
|
||||
(:subsection-heading s :subsection-heading-num sa 30 keep keepn nowidctlpar hyphpar 0 level 4 b :10-pt :english-uk)
|
||||
((+ :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-uk)
|
||||
((+ :styles) (:grammar-header sbasedon :normal-num snext :grammar-lhs-num "Grammar Header;"))
|
||||
|
||||
(:grammar-lhs-num 12)
|
||||
(:grammar-lhs s :grammar-lhs-num fi -1440 li 1800 sb 120 keep keepn nowidctlpar hyphpar 0 outlinelevel 4 :10-pt :no-language)
|
||||
((+ :styles) (:grammar-lhs sbasedon :grammar-num snext :grammar-rhs-num "Grammar LHS;"))
|
||||
|
||||
(:grammar-lhs-last-num 13)
|
||||
(:grammar-lhs-last s :grammar-lhs-last-num fi -1440 li 1800 sb 120 sa 120 keep nowidctlpar hyphpar 0 outlinelevel 4 :10-pt :no-language)
|
||||
((+ :styles) (:grammar-lhs-last sbasedon :grammar-num snext :grammar-lhs-num "Grammar LHS Last;"))
|
||||
|
||||
(:grammar-rhs-num 14)
|
||||
(:grammar-rhs s :grammar-rhs-num fi -1260 li 1800 keep keepn nowidctlpar tx 720 hyphpar 0 :10-pt :no-language)
|
||||
((+ :styles) (:grammar-rhs sbasedon :grammar-num snext :grammar-rhs-num "Grammar RHS;"))
|
||||
|
||||
(:grammar-rhs-last-num 15)
|
||||
(:grammar-rhs-last s :grammar-rhs-last-num fi -1260 li 1800 sa 120 keep nowidctlpar tx 720 hyphpar 0 :10-pt :no-language)
|
||||
((+ :styles) (:grammar-rhs-last sbasedon :grammar-rhs-num snext :grammar-lhs-num "Grammar RHS Last;"))
|
||||
|
||||
(:grammar-argument-num 16)
|
||||
(:grammar-argument s :grammar-argument-num fi -1440 li 1800 sb 120 sa 120 keep nowidctlpar hyphpar 0 outlinelevel 4 :10-pt :no-language)
|
||||
((+ :styles) (:grammar-argument sbasedon :grammar-num snext :grammar-lhs-num "Grammar Argument;"))
|
||||
|
||||
(:semantics-num 20)
|
||||
(:semantics s :semantics-num li 180 sb 60 sa 60 keep nowidctlpar hyphpar 0 :10-pt :no-language)
|
||||
((+ :styles) (:semantics sbasedon :normal-num snext :semantics-num "Semantics;"))
|
||||
|
||||
(:semantics-next-num 21)
|
||||
(:semantics-next s :semantics-next-num li 540 sa 60 keep nowidctlpar hyphpar 0 :10-pt :no-language)
|
||||
((+ :styles) (:semantics-next sbasedon :semantics-num snext :semantics-next-num "Semantics Next;"))
|
||||
|
||||
(:default-paragraph-font-num 30)
|
||||
(:default-paragraph-font cs :default-paragraph-font-num)
|
||||
((+ :styles) (* :default-paragraph-font additive "Default Paragraph Font;"))
|
||||
|
||||
(:character-literal-num 31)
|
||||
(: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 32)
|
||||
(:character-literal-control cs :character-literal-control-num b 0 :times :dark-blue)
|
||||
((+ :styles) (* :character-literal-control additive sbasedon :default-paragraph-font-num "Character Literal Control;"))
|
||||
|
||||
(:terminal-num 33)
|
||||
(:terminal cs :terminal-num b :palatino :teal :no-language)
|
||||
((+ :styles) (* :terminal additive sbasedon :default-paragraph-font-num "Terminal;"))
|
||||
|
||||
(:terminal-keyword-num 34)
|
||||
(:terminal-keyword cs :terminal-keyword-num b :courier :blue :no-language)
|
||||
((+ :styles) (* :terminal-keyword additive sbasedon :terminal-num "Terminal Keyword;"))
|
||||
|
||||
(:nonterminal-num 35)
|
||||
(:nonterminal cs :nonterminal-num i :palatino :dark-red :no-language)
|
||||
((+ :styles) (* :nonterminal additive sbasedon :default-paragraph-font-num "Nonterminal;"))
|
||||
|
||||
(:nonterminal-attribute-num 36)
|
||||
(:nonterminal-attribute cs :nonterminal-attribute-num i 0)
|
||||
((+ :styles) (* :nonterminal-attribute additive sbasedon :default-paragraph-font-num "Nonterminal Attribute;"))
|
||||
|
||||
(:nonterminal-argument-num 37)
|
||||
(:nonterminal-argument cs :nonterminal-argument-num)
|
||||
((+ :styles) (* :nonterminal-argument additive sbasedon :default-paragraph-font-num "Nonterminal Argument;"))
|
||||
|
||||
(:semantic-keyword-num 40)
|
||||
(:semantic-keyword cs :semantic-keyword-num b :times)
|
||||
((+ :styles) (* :semantic-keyword additive sbasedon :default-paragraph-font-num "Semantic Keyword;"))
|
||||
|
||||
(:type-expression-num 41)
|
||||
(:type-expression cs :type-expression-num :times :red :no-language)
|
||||
((+ :styles) (* :type-expression additive sbasedon :default-paragraph-font-num "Type Expression;"))
|
||||
|
||||
(:type-name-num 42)
|
||||
(:type-name cs :type-name-num scaps :times :red :no-language)
|
||||
((+ :styles) (* :type-name additive sbasedon :type-expression-num "Type Name;"))
|
||||
|
||||
(:field-name-num 43)
|
||||
(:field-name cs :field-name-num :helvetica :red :no-language)
|
||||
((+ :styles) (* :field-name additive sbasedon :type-expression-num "Field Name;"))
|
||||
|
||||
(:global-variable-num 44)
|
||||
(:global-variable cs :global-variable-num i :times :green :no-language)
|
||||
((+ :styles) (* :global-variable additive sbasedon :default-paragraph-font-num "Global Variable;"))
|
||||
|
||||
(:local-variable-num 45)
|
||||
(:local-variable cs :local-variable-num i :times :bright-green :no-language)
|
||||
((+ :styles) (* :local-variable additive sbasedon :default-paragraph-font-num "Local Variable;"))
|
||||
|
||||
(:action-name-num 46)
|
||||
(:action-name cs :action-name-num :zapf-chancery :violet :no-language)
|
||||
((+ :styles) (* :action-name additive sbasedon :default-paragraph-font-num "Action Name;"))
|
||||
|
||||
|
||||
;Document Formatting
|
||||
((+ :rtf-intro) :docfmt)
|
||||
(: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
|
||||
(:invisible v)
|
||||
((:but-not 6) (b "except"))
|
||||
(:subscript sub)
|
||||
(:superscript super)
|
||||
(:plain-subscript b 0 i 0 :subscript)
|
||||
((:action-begin 1) "[")
|
||||
((:action-end 1) "]")
|
||||
((:vector-begin 1) (b "["))
|
||||
((:vector-end 1) (b "]"))
|
||||
((:empty-vector 2) (b "[]"))
|
||||
((:vector-append 2) :big-plus-10)
|
||||
((:tuple-begin 1) (b :left-triangle-bracket-10))
|
||||
((:tuple-end 1) (b :right-triangle-bracket-10))
|
||||
((:unit 4) (:global-variable "unit"))
|
||||
((:true 4) (:global-variable "true"))
|
||||
((:false 5) (:global-variable "false"))
|
||||
))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; SIMPLE LINE BREAKER
|
||||
|
||||
(defparameter *limited-line-right-margin* 100)
|
||||
|
||||
; Housekeeping dynamic variables
|
||||
(defvar *current-limited-lines*) ;Items written so far via break-line to the innermost write-limited-lines
|
||||
(defvar *current-limited-lines-non-empty*) ;True if something was written to *current-limited-lines*
|
||||
(defvar *current-limited-position*) ;Number of characters written since the last newline to *current-limited-lines*
|
||||
|
||||
|
||||
; Capture the text written by the emitter function to its single parameter
|
||||
; (an output stream), dividing the text as specified by dynamically scoped calls
|
||||
; to break-line. Return the text as a base-string.
|
||||
(defun write-limited-lines (emitter)
|
||||
(let ((limited-stream (make-string-output-stream :element-type 'base-character))
|
||||
(*current-limited-lines* (make-string-output-stream :element-type 'base-character))
|
||||
(*current-limited-lines-non-empty* nil)
|
||||
(*current-limited-position* 0))
|
||||
(funcall emitter limited-stream)
|
||||
(break-line limited-stream)
|
||||
(get-output-stream-string *current-limited-lines*)))
|
||||
|
||||
|
||||
; Capture the text written by the emitter body to stream-var,
|
||||
; dividing the text as specified by dynamically scoped calls
|
||||
; to break-line. Write the result to the stream-var stream.
|
||||
(defmacro write-limited-block (stream-var &body emitter)
|
||||
`(progn
|
||||
(write-string
|
||||
(write-limited-lines #'(lambda (,stream-var) ,@emitter))
|
||||
,stream-var)
|
||||
nil))
|
||||
|
||||
|
||||
; Indicate that this is a potential place for a line break in the stream provided
|
||||
; by write-limited-lines. If subdivide is true, also indicate that line breaks can
|
||||
; be inserted anywhere between this point and the last such point indicated by break-line
|
||||
; (or the beginning of write-limited-lines, whichever came last).
|
||||
(defun break-line (limited-stream &optional subdivide)
|
||||
(let* ((new-chars (get-output-stream-string limited-stream))
|
||||
(length (length new-chars)))
|
||||
(unless (zerop length)
|
||||
(labels
|
||||
((subdivide-new-chars (start)
|
||||
(let ((length-remaining (- length start))
|
||||
(room-on-line (- *limited-line-right-margin* *current-limited-position*)))
|
||||
(if (>= room-on-line length-remaining)
|
||||
(progn
|
||||
(write-string new-chars *current-limited-lines* :start start)
|
||||
(incf *current-limited-position* length-remaining))
|
||||
(let ((end (+ start room-on-line)))
|
||||
(write-string new-chars *current-limited-lines* :start start :end end)
|
||||
(write-char #\newline *current-limited-lines*)
|
||||
(setq *current-limited-position* 0)
|
||||
(subdivide-new-chars end))))))
|
||||
|
||||
(let ((position (+ *current-limited-position* length))
|
||||
(has-newlines (find #\newline new-chars)))
|
||||
(cond
|
||||
((or has-newlines
|
||||
(and (> position *limited-line-right-margin*) (not subdivide)))
|
||||
(when *current-limited-lines-non-empty*
|
||||
(write-char #\newline *current-limited-lines*))
|
||||
(write-string new-chars *current-limited-lines*)
|
||||
;Force a line break if break-line is called again and the current
|
||||
;new-chars contained a line break.
|
||||
(setq *current-limited-position*
|
||||
(if has-newlines
|
||||
(1+ *limited-line-right-margin*)
|
||||
length)))
|
||||
((<= position *limited-line-right-margin*)
|
||||
(write-string new-chars *current-limited-lines*)
|
||||
(setq *current-limited-position* position))
|
||||
((>= *current-limited-position* *limited-line-right-margin*)
|
||||
(write-char #\newline *current-limited-lines*)
|
||||
(setq *current-limited-position* 0)
|
||||
(subdivide-new-chars 0))
|
||||
(t (subdivide-new-chars 0)))
|
||||
(setq *current-limited-lines-non-empty* t))))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; RTF READER
|
||||
|
||||
|
||||
; Return true if char can be a part of an RTF control word.
|
||||
(defun rtf-control-word-char? (char)
|
||||
(and (char>= char #\a) (char<= char #\z)))
|
||||
|
||||
|
||||
; Read RTF from the character stream and return it in list form.
|
||||
; Each { ... } group is a sublist.
|
||||
; Each RTF control symbol or word is represented by a lisp symbol.
|
||||
; If an RTF control has a numeric argument, then its lisp symbol is followed
|
||||
; by an integer equal to the argument's value.
|
||||
; Newlines not escaped by backslashes are ignored.
|
||||
(defun read-rtf (stream)
|
||||
(labels
|
||||
((read (&optional (eof-error-p t))
|
||||
(read-char stream eof-error-p nil))
|
||||
|
||||
(read-group (nested)
|
||||
(let ((char (read nested)))
|
||||
(case char
|
||||
((nil) nil)
|
||||
(#\} (if nested
|
||||
nil
|
||||
(error "Mismatched }")))
|
||||
(#\{ (cons
|
||||
(read-group t)
|
||||
(read-group nested)))
|
||||
(#\\ (append
|
||||
(read-control)
|
||||
(read-group nested)))
|
||||
(#\newline (read-group nested))
|
||||
(t (read-text nested (list char))))))
|
||||
|
||||
(read-text (nested chars)
|
||||
(let ((char (read nested)))
|
||||
(case char
|
||||
((nil)
|
||||
(list (coerce (nreverse chars) 'string)))
|
||||
((#\{ #\} #\\)
|
||||
(cons (coerce (nreverse chars) 'string)
|
||||
(progn
|
||||
(unread-char char stream)
|
||||
(read-group nested))))
|
||||
(#\newline (read-text nested chars))
|
||||
(t (read-text nested (cons char chars))))))
|
||||
|
||||
(read-integer (value need-digit)
|
||||
(let* ((char (read))
|
||||
(digit (digit-char-p char)))
|
||||
(cond
|
||||
(digit (read-integer (+ (* value 10) digit) nil))
|
||||
(need-digit (error "Empty number"))
|
||||
((eql char #\space) value)
|
||||
(t (unread-char char stream)
|
||||
value))))
|
||||
|
||||
(read-hex (n-digits)
|
||||
(let ((value 0))
|
||||
(dotimes (n n-digits)
|
||||
(let ((digit (digit-char-p (read) 16)))
|
||||
(unless digit
|
||||
(error "Bad hex digit"))
|
||||
(setq value (+ (* value 16) digit))))
|
||||
value))
|
||||
|
||||
(read-control ()
|
||||
(let ((char (read)))
|
||||
(if (rtf-control-word-char? char)
|
||||
(let* ((control-string (read-control-word (list char)))
|
||||
(control-symbol (intern (string-upcase control-string)))
|
||||
(char (read)))
|
||||
(case char
|
||||
(#\space (list control-symbol))
|
||||
(#\- (list control-symbol (- (read-integer 0 t))))
|
||||
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
|
||||
(unread-char char stream)
|
||||
(list control-symbol (read-integer 0 t)))
|
||||
(t (unread-char char stream)
|
||||
(list control-symbol))))
|
||||
(let* ((control-string (string char))
|
||||
(control-symbol (intern (string-upcase control-string))))
|
||||
(if (eq control-symbol '\')
|
||||
(list control-symbol (read-hex 2))
|
||||
(list control-symbol))))))
|
||||
|
||||
(read-control-word (chars)
|
||||
(let ((char (read)))
|
||||
(if (rtf-control-word-char? char)
|
||||
(read-control-word (cons char chars))
|
||||
(progn
|
||||
(unread-char char stream)
|
||||
(coerce (nreverse chars) 'string))))))
|
||||
|
||||
(read-group nil)))
|
||||
|
||||
|
||||
; Read RTF from the text file with the given name (relative to the
|
||||
; local directory) and return it in list form.
|
||||
(defun read-rtf-from-local-file (filename)
|
||||
(with-open-file (stream (merge-pathnames filename *semantic-engine-directory*)
|
||||
:direction :input)
|
||||
(read-rtf stream)))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; RTF WRITER
|
||||
|
||||
|
||||
(defconstant *rtf-special* '(#\\ #\{ #\}))
|
||||
|
||||
|
||||
; Return the string with characters in *rtf-special* preceded by backslashes.
|
||||
; If there are no such characters, the returned string may be eq to the input string.
|
||||
(defun escape-rtf (string)
|
||||
(let ((i (position-if #'(lambda (char) (member char *rtf-special*)) string)))
|
||||
(if i
|
||||
(let* ((string-length (length string))
|
||||
(result-string (make-array string-length :element-type 'base-character :adjustable t :fill-pointer i)))
|
||||
(replace result-string string)
|
||||
(do ((i i (1+ i)))
|
||||
((= i string-length))
|
||||
(let ((char (char string i)))
|
||||
(when (member char *rtf-special*)
|
||||
(vector-push-extend #\\ result-string))
|
||||
(vector-push-extend char result-string)))
|
||||
result-string)
|
||||
string)))
|
||||
|
||||
|
||||
; Write RTF to the character stream. See read-rtf for a description
|
||||
; of the layout of the rtf list.
|
||||
(defun write-rtf (rtf &optional (stream t))
|
||||
(labels
|
||||
((write-group-contents (rtf stream)
|
||||
(let ((first-rtf (first rtf))
|
||||
(rest-rtf (rest rtf)))
|
||||
(cond
|
||||
((listp first-rtf)
|
||||
(write-group first-rtf stream t))
|
||||
((stringp first-rtf)
|
||||
(write-string (escape-rtf first-rtf) stream)
|
||||
(break-line stream t))
|
||||
((symbolp first-rtf)
|
||||
(write-char #\\ stream)
|
||||
(write first-rtf :stream stream)
|
||||
(cond
|
||||
((alpha-char-p (char (symbol-name first-rtf) 0))
|
||||
(when (integerp (first rest-rtf))
|
||||
(write (first rest-rtf) :stream stream)
|
||||
(setq rest-rtf (rest rest-rtf)))
|
||||
(let ((first-rest (first rest-rtf)))
|
||||
(when (and (stringp first-rest)
|
||||
(or (zerop (length first-rest))
|
||||
(let ((ch (char first-rest 0)))
|
||||
(or (alphanumericp ch)
|
||||
(eql ch #\space)
|
||||
(eql ch #\-)
|
||||
(eql ch #\+)))))
|
||||
(write-char #\space stream))))
|
||||
((eq first-rtf '\')
|
||||
(unless (integerp (first rest-rtf))
|
||||
(error "Bad rtf: ~S" rtf))
|
||||
(format stream "~2,'0x" (first rest-rtf))
|
||||
(setq rest-rtf (rest rest-rtf)))))
|
||||
(t (error "Bad rtf: ~S" rtf)))
|
||||
(when rest-rtf
|
||||
(break-line stream)
|
||||
(write-group-contents rest-rtf stream))))
|
||||
|
||||
(write-group (rtf stream nested)
|
||||
(write-limited-block stream
|
||||
(when nested
|
||||
(write-char #\{ stream))
|
||||
(when rtf
|
||||
(write-group-contents rtf stream))
|
||||
(when nested
|
||||
(write-char #\} stream)))))
|
||||
|
||||
(with-standard-io-syntax
|
||||
(let ((*print-readably* nil)
|
||||
(*print-escape* nil)
|
||||
(*print-case* :downcase))
|
||||
(write-group rtf stream nil)))))
|
||||
|
||||
|
||||
; Write RTF to the text file with the given name (relative to the
|
||||
; local directory).
|
||||
(defun write-rtf-to-local-file (filename rtf)
|
||||
(with-open-file (stream (merge-pathnames filename *semantic-engine-directory*)
|
||||
:direction :output
|
||||
:if-exists :supersede
|
||||
#+mcl :external-format #+mcl "RTF "
|
||||
#+mcl :mac-file-creator #+mcl "MSWD")
|
||||
(write-rtf rtf stream)))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; RTF STREAMS
|
||||
|
||||
(defstruct (rtf-stream (:include markup-stream)
|
||||
(:constructor allocate-rtf-stream (env head tail level logical-position))
|
||||
(:copier nil)
|
||||
(:predicate rtf-stream?))
|
||||
(style nil :type symbol)) ;Current section or paragraph style or nil if none or emitting paragraph contents
|
||||
|
||||
|
||||
(defmethod print-object ((rtf-stream rtf-stream) stream)
|
||||
(print-unreadable-object (rtf-stream stream :identity t)
|
||||
(write-string "rtf-stream" stream)))
|
||||
|
||||
|
||||
; Make a new, empty, open rtf-stream with the given definitions for its markup-env.
|
||||
(defun make-rtf-stream (markup-env level &optional logical-position)
|
||||
(let ((head (list nil)))
|
||||
(allocate-rtf-stream markup-env head head level logical-position)))
|
||||
|
||||
|
||||
; Make a new, empty, open, top-level rtf-stream with the given definitions
|
||||
; for its markup-env.
|
||||
(defun make-top-level-rtf-stream (rtf-definitions)
|
||||
(let ((head (list nil))
|
||||
(markup-env (make-markup-env)))
|
||||
(markup-env-define-alist markup-env rtf-definitions)
|
||||
(allocate-rtf-stream markup-env head head *markup-stream-top-level* nil)))
|
||||
|
||||
|
||||
; Append a block to the end of the rtf-stream. The block may be inlined
|
||||
; if nothing else follows it in the rtf-stream.
|
||||
(defun rtf-stream-append-or-inline-block (rtf-stream block)
|
||||
(assert-type block list)
|
||||
(when block
|
||||
(let ((pretail (markup-stream-tail rtf-stream)))
|
||||
(markup-stream-append1 rtf-stream block)
|
||||
(setf (markup-stream-pretail rtf-stream) pretail))))
|
||||
|
||||
|
||||
; Return the approximate width of the rtf item; return t if it is a line break.
|
||||
; Also allow rtf groups as long as they do not contain line breaks.
|
||||
(defmethod markup-group-width ((rtf-stream rtf-stream) item)
|
||||
(if (consp item)
|
||||
(reduce #'+ item :key #'(lambda (subitem) (markup-group-width rtf-stream subitem)))
|
||||
(markup-width rtf-stream item)))
|
||||
|
||||
|
||||
; Create a top-level rtf-stream and call emitter to emit its contents.
|
||||
; emitter takes one argument -- an rtf-stream to which it should emit paragraphs.
|
||||
; Return the top-level rtf-stream.
|
||||
(defun depict-rtf-top-level (emitter)
|
||||
(let* ((top-rtf-stream (make-top-level-rtf-stream *rtf-definitions*))
|
||||
(rtf-stream (make-rtf-stream (markup-stream-env top-rtf-stream) *markup-stream-paragraph-level*)))
|
||||
(markup-stream-append1 rtf-stream ':rtf-intro)
|
||||
(markup-stream-append1 rtf-stream ':reset-section)
|
||||
(funcall emitter rtf-stream)
|
||||
(markup-stream-append1 top-rtf-stream (markup-stream-unexpanded-output rtf-stream))
|
||||
top-rtf-stream))
|
||||
|
||||
|
||||
; Create a top-level rtf-stream and call emitter to emit its contents.
|
||||
; emitter takes one argument -- an rtf-stream to which it should emit paragraphs.
|
||||
; Write the resulting RTF to the text file with the given name (relative to the
|
||||
; local directory).
|
||||
(defun depict-rtf-to-local-file (filename emitter)
|
||||
(let ((top-rtf-stream (depict-rtf-top-level emitter)))
|
||||
(write-rtf-to-local-file filename (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 emitter)
|
||||
(declare (ignore block-style))
|
||||
(assert-true (= (markup-stream-level rtf-stream) *markup-stream-paragraph-level*))
|
||||
(funcall emitter rtf-stream))
|
||||
|
||||
|
||||
(defmethod depict-paragraph-f ((rtf-stream rtf-stream) paragraph-style emitter)
|
||||
(assert-true (= (markup-stream-level rtf-stream) *markup-stream-paragraph-level*))
|
||||
(assert-true (and paragraph-style (symbolp paragraph-style)))
|
||||
(unless (eq paragraph-style (rtf-stream-style rtf-stream))
|
||||
(markup-stream-append1 rtf-stream ':reset-paragraph)
|
||||
(markup-stream-append1 rtf-stream paragraph-style))
|
||||
(setf (rtf-stream-style rtf-stream) nil)
|
||||
(setf (markup-stream-level rtf-stream) *markup-stream-content-level*)
|
||||
(setf (markup-stream-logical-position rtf-stream) (make-logical-position))
|
||||
(prog1
|
||||
(funcall emitter rtf-stream)
|
||||
(setf (markup-stream-level rtf-stream) *markup-stream-paragraph-level*)
|
||||
(setf (rtf-stream-style rtf-stream) paragraph-style)
|
||||
(setf (markup-stream-logical-position rtf-stream) nil)
|
||||
(markup-stream-append1 rtf-stream ':new-paragraph)))
|
||||
|
||||
|
||||
(defmethod depict-char-style-f ((rtf-stream rtf-stream) char-style emitter)
|
||||
(assert-true (>= (markup-stream-level rtf-stream) *markup-stream-content-level*))
|
||||
(assert-true (and char-style (symbolp char-style)))
|
||||
(let ((inner-rtf-stream (make-rtf-stream (markup-stream-env rtf-stream) *markup-stream-content-level* (markup-stream-logical-position rtf-stream))))
|
||||
(markup-stream-append1 inner-rtf-stream char-style)
|
||||
(prog1
|
||||
(funcall emitter inner-rtf-stream)
|
||||
(rtf-stream-append-or-inline-block rtf-stream (markup-stream-unexpanded-output inner-rtf-stream)))))
|
||||
|
||||
|
||||
#|
|
||||
(setq r (read-rtf-from-local-file "SampleStyles.rtf"))
|
||||
(write-rtf-to-local-file "Y.rtf" r)
|
||||
|#
|
||||
|
|
@ -0,0 +1,507 @@
|
|||
;;; The contents of this file are subject to the Netscape Public License
|
||||
;;; Version 1.0 (the "NPL"); you may not use this file except in
|
||||
;;; compliance with the NPL. You may obtain a copy of the NPL at
|
||||
;;; http://www.mozilla.org/NPL/
|
||||
;;;
|
||||
;;; Software distributed under the NPL is distributed on an "AS IS" basis,
|
||||
;;; WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
|
||||
;;; for the specific language governing rights and limitations under the
|
||||
;;; NPL.
|
||||
;;;
|
||||
;;; The Initial Developer of this code under the NPL is Netscape
|
||||
;;; Communications Corporation. Portions created by Netscape are
|
||||
;;; Copyright (C) 1998 Netscape Communications Corporation. All Rights
|
||||
;;; Reserved.
|
||||
|
||||
;;;
|
||||
;;; Handy lisp utilities
|
||||
;;;
|
||||
;;; Waldemar Horwat (waldemar@netscape.com)
|
||||
;;;
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; MCL FIXES
|
||||
|
||||
|
||||
(setq *print-right-margin* 150)
|
||||
|
||||
;;; Fix name-char and char-name.
|
||||
#+mcl
|
||||
(locally
|
||||
(declare (optimize (speed 3) (safety 0) (debug 1)))
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(setq *warn-if-redefine* nil)
|
||||
(setq *warn-if-redefine-kernel* nil))
|
||||
|
||||
(defun char-name (c)
|
||||
(dolist (e ccl::*name-char-alist*)
|
||||
(declare (list e))
|
||||
(when (eq c (cdr e))
|
||||
(return-from char-name (car e))))
|
||||
(let ((code (char-code c)))
|
||||
(declare (fixnum code))
|
||||
(cond ((< code #x100)
|
||||
(unless (and (>= code 32) (<= code 216) (/= code 127))
|
||||
(format nil "x~2,'0X" code)))
|
||||
(t (format nil "u~4,'0X" code)))))
|
||||
|
||||
(defun name-char (name)
|
||||
(if (characterp name)
|
||||
name
|
||||
(let* ((name (string name))
|
||||
(namelen (length name)))
|
||||
(declare (fixnum namelen))
|
||||
(or (cdr (assoc name ccl::*name-char-alist* :test #'string-equal))
|
||||
(if (= namelen 1)
|
||||
(char name 0)
|
||||
(when (>= namelen 2)
|
||||
(flet
|
||||
((number-char (name base lg-base)
|
||||
(let ((n 0))
|
||||
(dotimes (i (length name) (code-char n))
|
||||
(let ((code (digit-char-p (char name i) base)))
|
||||
(if code
|
||||
(setq n (logior code (ash n lg-base)))
|
||||
(return)))))))
|
||||
(case (char name 0)
|
||||
(#\^
|
||||
(when (= namelen 2)
|
||||
(code-char (the fixnum (logxor (the fixnum (char-code (char-upcase (char name 1)))) #x40)))))
|
||||
((#\x #\X #\u #\U)
|
||||
(number-char (subseq name 1) 16 4))
|
||||
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7)
|
||||
(number-char name 8 3))))))))))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(setq *warn-if-redefine* t)
|
||||
(setq *warn-if-redefine-kernel* t)))
|
||||
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; READER SYNTAX
|
||||
|
||||
; Define #?num to produce a character with code given by the hexadecimal number num.
|
||||
; (This is a portable extension; the #\u syntax installed above does the same thing
|
||||
; but is not portable.)
|
||||
(set-dispatch-macro-character
|
||||
#\# #\?
|
||||
#'(lambda (stream subchar arg)
|
||||
(declare (ignore subchar arg))
|
||||
(let ((*read-base* 16))
|
||||
(code-char (read stream t nil t)))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; MACROS
|
||||
|
||||
; (list*-bind (var1 var2 ... varn) expr body):
|
||||
; evaluates expr to obtain a value v;
|
||||
; binds var1, var2, ..., varn such that (list* var1 var2 ... varn) is equal to v;
|
||||
; evaluates body with these bindings;
|
||||
; returns the result values from the body.
|
||||
(defmacro list*-bind ((var1 &rest vars) expr &body body)
|
||||
(labels
|
||||
((gen-let*-bindings (var1 vars expr)
|
||||
(if vars
|
||||
(let ((expr-var (gensym "REST")))
|
||||
(list*
|
||||
(list expr-var expr)
|
||||
(list var1 (list 'car expr-var))
|
||||
(gen-let*-bindings (car vars) (cdr vars) (list 'cdr expr-var))))
|
||||
(list
|
||||
(list var1 expr)))))
|
||||
(list* 'let* (gen-let*-bindings var1 vars expr) body)))
|
||||
|
||||
(set-pprint-dispatch '(cons (member list*-bind))
|
||||
(pprint-dispatch '(multiple-value-bind () ())))
|
||||
|
||||
|
||||
; (multiple-value-map-bind (var1 var2 ... varn) f (src1 src2 ... srcm) body)
|
||||
; evaluates src1, src2, ..., srcm to obtain lists l1, l2, ..., lm;
|
||||
; calls f on corresponding elements of lists l1, ..., lm; each such call should return n values v1 v2 ... vn;
|
||||
; binds var1, var2, ..., varn such var1 is the list of all v1's, var2 is the list of all v2's, etc.;
|
||||
; evaluates body with these bindings;
|
||||
; returns the result values from the body.
|
||||
(defmacro multiple-value-map-bind ((&rest vars) f (&rest srcs) &body body)
|
||||
(let ((n (length vars))
|
||||
(m (length srcs))
|
||||
(fun (gensym "F"))
|
||||
(ss nil)
|
||||
(vs nil)
|
||||
(accumulators nil))
|
||||
(dotimes (i n)
|
||||
(push (gensym "V") vs)
|
||||
(push (gensym "ACC") accumulators))
|
||||
(dotimes (i m)
|
||||
(push (gensym "S") ss))
|
||||
`(let ((,fun ,f)
|
||||
,@(mapcar #'(lambda (acc) (list acc nil)) accumulators))
|
||||
(mapc #'(lambda ,ss
|
||||
(multiple-value-bind ,vs (funcall ,fun ,@ss)
|
||||
,@(mapcar #'(lambda (accumulator v) (list 'push v accumulator))
|
||||
accumulators vs)))
|
||||
,@srcs)
|
||||
(let ,(mapcar #'(lambda (var accumulator) (list var (list 'nreverse accumulator)))
|
||||
vars accumulators)
|
||||
,@body))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; VALUE ASSERTS
|
||||
|
||||
(defconstant *value-asserts* t)
|
||||
|
||||
; Assert that (test value) returns non-nil. Return value.
|
||||
(defmacro assert-value (value test &rest format-and-parameters)
|
||||
(if *value-asserts*
|
||||
(let ((v (gensym "VALUE")))
|
||||
`(let ((,v ,value))
|
||||
(unless (,test ,v)
|
||||
,(if format-and-parameters
|
||||
`(error ,@format-and-parameters)
|
||||
`(error "~S doesn't satisfy ~S" ',value ',test)))
|
||||
,v))
|
||||
value))
|
||||
|
||||
|
||||
; Assert that value is non-nil. Return value.
|
||||
(defmacro assert-non-null (value &rest format-and-parameters)
|
||||
`(assert-value ,value identity .
|
||||
,(or format-and-parameters
|
||||
`("~S is null" ',value))))
|
||||
|
||||
|
||||
; Assert that value is non-nil. Return nil.
|
||||
; Do not evaluate value in nondebug versions.
|
||||
(defmacro assert-true (value &rest format-and-parameters)
|
||||
(if *value-asserts*
|
||||
`(unless ,value
|
||||
,(if format-and-parameters
|
||||
`(error ,@format-and-parameters)
|
||||
`(error "~S is false" ',value)))
|
||||
nil))
|
||||
|
||||
|
||||
; Assert that expr returns n values. Return those values.
|
||||
(defmacro assert-n-values (n expr)
|
||||
(if *value-asserts*
|
||||
(let ((v (gensym "VALUES")))
|
||||
`(let ((,v (multiple-value-list ,expr)))
|
||||
(unless (= (length ,v) ,n)
|
||||
(error "~S returns ~D values instead of ~D" ',expr (length ,v) ',n))
|
||||
(values-list ,v)))
|
||||
expr))
|
||||
|
||||
; Assert that expr returns one value. Return that value.
|
||||
(defmacro assert-one-value (expr)
|
||||
`(assert-n-values 1 ,expr))
|
||||
|
||||
; Assert that expr returns two values. Return those values.
|
||||
(defmacro assert-two-values (expr)
|
||||
`(assert-n-values 2 ,expr))
|
||||
|
||||
; Assert that expr returns three values. Return those values.
|
||||
(defmacro assert-three-values (expr)
|
||||
`(assert-n-values 3 ,expr))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; STRUCTURED TYPES
|
||||
|
||||
(defconstant *type-asserts* t)
|
||||
|
||||
(defun tuple? (value structured-types)
|
||||
(if (endp structured-types)
|
||||
(null value)
|
||||
(and (consp value)
|
||||
(structured-type? (car value) (first structured-types))
|
||||
(tuple? (cdr value) (rest structured-types)))))
|
||||
|
||||
(defun list-of? (value structured-type)
|
||||
(or
|
||||
(null value)
|
||||
(and (consp value)
|
||||
(structured-type? (car value) structured-type)
|
||||
(list-of? (cdr value) structured-type))))
|
||||
|
||||
|
||||
; Return true if value has the given structured-type.
|
||||
; A structured-type can be a Common Lisp type or one of the forms below:
|
||||
;
|
||||
; (cons t1 t2) is the type of pairs whose car has structured-type t1 and
|
||||
; cdr has structured-type t2.
|
||||
;
|
||||
; (tuple t1 t2 ... tn) is the type of n-element lists whose first element
|
||||
; has structured-type t1, second element has structured-type t2, ...,
|
||||
; and last element has structured-type tn.
|
||||
;
|
||||
; (list t) is the type of lists all of whose elements have structured-type t.
|
||||
;
|
||||
(defun structured-type? (value structured-type)
|
||||
(cond
|
||||
((consp structured-type)
|
||||
(case (first structured-type)
|
||||
(cons (and (consp value)
|
||||
(structured-type? (car value) (second structured-type))
|
||||
(structured-type? (cdr value) (third structured-type))))
|
||||
(tuple (tuple? value (rest structured-type)))
|
||||
(list (list-of? value (second structured-type)))
|
||||
(t (typep value structured-type))))
|
||||
((null structured-type) nil)
|
||||
(t (typep value structured-type))))
|
||||
|
||||
|
||||
; Ensure that value has type given by typespec
|
||||
; (which should not be quoted). Return the value.
|
||||
(defmacro assert-type (value structured-type)
|
||||
(if *type-asserts*
|
||||
(let ((v (gensym "VALUE")))
|
||||
`(let ((,v ,value))
|
||||
(unless (structured-type? ,v ',structured-type)
|
||||
(error "~S should have type ~S" ,v ',structured-type))
|
||||
,v))
|
||||
value))
|
||||
|
||||
(deftype bool () '(member nil t))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; GENERAL UTILITIES
|
||||
|
||||
|
||||
; f must be either a function, a symbol, or a list of the form (setf <symbol>).
|
||||
; If f is a function or has a function binding, return that function; otherwise return nil.
|
||||
(defun callable (f)
|
||||
(cond
|
||||
((functionp f) f)
|
||||
((fboundp f) (fdefinition f))
|
||||
(t nil)))
|
||||
|
||||
|
||||
; Return the first character of symbol's name or nil if s's name has zero length.
|
||||
(defun first-symbol-char (symbol)
|
||||
(let ((name (symbol-name symbol)))
|
||||
(when (> (length name) 0)
|
||||
(char name 0))))
|
||||
|
||||
|
||||
(defconstant *get2-nonce* (if (boundp '*get2-nonce*) (symbol-value '*get2-nonce*) (gensym)))
|
||||
|
||||
; Perform a get except that return two values:
|
||||
; The value returned from the get or nil if the property is not present
|
||||
; t if the property is present or nil if not.
|
||||
(defun get2 (symbol property)
|
||||
(let ((value (get symbol property *get2-nonce*)))
|
||||
(if (eq value *get2-nonce*)
|
||||
(values nil nil)
|
||||
(values value t))))
|
||||
|
||||
|
||||
; Return a list of all the keys in the hash table.
|
||||
(defun hash-table-keys (hash-table)
|
||||
(let ((keys nil))
|
||||
(maphash #'(lambda (key value)
|
||||
(declare (ignore value))
|
||||
(push key keys))
|
||||
hash-table)
|
||||
keys))
|
||||
|
||||
|
||||
; Return a list of all the keys in the hash table sorted by their string representations.
|
||||
(defun sorted-hash-table-keys (hash-table)
|
||||
(with-standard-io-syntax
|
||||
(let ((*print-readably* nil)
|
||||
(*print-escape* nil))
|
||||
(sort (hash-table-keys hash-table) #'string< :key #'write-to-string))))
|
||||
|
||||
|
||||
; Given an association list ((key1 . data1) (key2 . data2) ... (keyn datan)),
|
||||
; produce another association list whose keys are sets of the keys of the original list,
|
||||
; where the data elements of each such set are equal according to the given test function.
|
||||
; The keys within each set are listed in the same order as in the original list.
|
||||
; Set X comes before set Y if X contains a key earlier in the original list than any
|
||||
; key in Y.
|
||||
(defun collect-equivalences (alist &key (test #'eql))
|
||||
(if (endp alist)
|
||||
nil
|
||||
(let* ((element (car alist))
|
||||
(key (car element))
|
||||
(data (cdr element))
|
||||
(rest (cdr alist)))
|
||||
(if (rassoc data rest :test test)
|
||||
(let ((filtered-rest nil)
|
||||
(additional-keys nil))
|
||||
(dolist (elt rest)
|
||||
(if (funcall test data (cdr elt))
|
||||
(push (car elt) additional-keys)
|
||||
(push elt filtered-rest)))
|
||||
(acons (cons key (nreverse additional-keys)) data
|
||||
(collect-equivalences (nreverse filtered-rest) :test test)))
|
||||
(acons (list key) data (collect-equivalences rest :test test))))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; BITMAPS
|
||||
|
||||
; Treating integer m as a bitmap, call f on the number of each bit set in m.
|
||||
(defun bitmap-each-bit (f m)
|
||||
(assert-true (>= m 0))
|
||||
(dotimes (i (integer-length m))
|
||||
(when (logbitp i m)
|
||||
(funcall f i))))
|
||||
|
||||
|
||||
; Treating integer m as a bitmap, return a sorted list of disjoint, nonadjacent ranges
|
||||
; of bits set in m. Each range is a pair (x . y) and indicates that bits numbered x through
|
||||
; y, inclusive, are set in m. If m is negative, the last range will be a pair (x . :infinity).
|
||||
(defun bitmap-to-ranges (m)
|
||||
(labels
|
||||
((bitmap-to-ranges-sub (m ranges)
|
||||
(if (zerop m)
|
||||
ranges
|
||||
(let* ((hi (integer-length m))
|
||||
(m (- m (ash 1 hi)))
|
||||
(lo (integer-length m))
|
||||
(m (+ m (ash 1 lo))))
|
||||
(bitmap-to-ranges-sub m (acons lo (1- hi) ranges))))))
|
||||
(if (minusp m)
|
||||
(let* ((lo (integer-length m))
|
||||
(m (+ m (ash 1 lo))))
|
||||
(bitmap-to-ranges-sub m (list (cons lo :infinity))))
|
||||
(bitmap-to-ranges-sub m nil))))
|
||||
|
||||
|
||||
; Same as bitmap-to-ranges but abbreviate pairs (x . x) by x.
|
||||
(defun bitmap-to-abbreviated-ranges (m)
|
||||
(mapcar #'(lambda (range)
|
||||
(if (eql (car range) (cdr range))
|
||||
(car range)
|
||||
range))
|
||||
(bitmap-to-ranges m)))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; PACKAGES
|
||||
|
||||
; Call f on each external symbol defined in the package.
|
||||
(defun each-package-external-symbol (package f)
|
||||
(with-package-iterator (iter package :external)
|
||||
(loop
|
||||
(multiple-value-bind (present symbol) (iter)
|
||||
(unless present
|
||||
(return))
|
||||
(funcall f symbol)))))
|
||||
|
||||
|
||||
; Return a list of all external symbols defined in the package.
|
||||
(defun package-external-symbols (package)
|
||||
(with-package-iterator (iter package :external)
|
||||
(let ((list nil))
|
||||
(loop
|
||||
(multiple-value-bind (present symbol) (iter)
|
||||
(unless present
|
||||
(return))
|
||||
(push symbol list)))
|
||||
list)))
|
||||
|
||||
|
||||
; Return a sorted list of all external symbols defined in the package.
|
||||
(defun sorted-package-external-symbols (package)
|
||||
(sort (package-external-symbols package) #'string<))
|
||||
|
||||
|
||||
; Call f on each internal symbol defined in the package.
|
||||
(defun each-package-internal-symbol (package f)
|
||||
(with-package-iterator (iter package :internal)
|
||||
(loop
|
||||
(multiple-value-bind (present symbol) (iter)
|
||||
(unless present
|
||||
(return))
|
||||
(funcall f symbol)))))
|
||||
|
||||
|
||||
; Return a list of all internal symbols defined in the package.
|
||||
(defun package-internal-symbols (package)
|
||||
(with-package-iterator (iter package :internal)
|
||||
(let ((list nil))
|
||||
(loop
|
||||
(multiple-value-bind (present symbol) (iter)
|
||||
(unless present
|
||||
(return))
|
||||
(push symbol list)))
|
||||
list)))
|
||||
|
||||
|
||||
; Return a sorted list of all internal symbols defined in the package.
|
||||
(defun sorted-package-internal-symbols (package)
|
||||
(sort (package-internal-symbols package) #'string<))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; SETS
|
||||
|
||||
(defstruct (set (:constructor allocate-set (elts-hash)))
|
||||
(elts-hash nil :type hash-table :read-only t))
|
||||
|
||||
|
||||
; Make and return a new set.
|
||||
(defun make-set (&optional (test #'eql))
|
||||
(allocate-set (make-hash-table :test test)))
|
||||
|
||||
|
||||
; Add values to the set, modifying the set in place.
|
||||
; Return the set.
|
||||
(defun set-add (set &rest values)
|
||||
(let ((elements (set-elts-hash set)))
|
||||
(dolist (value values)
|
||||
(setf (gethash value elements) t)))
|
||||
set)
|
||||
|
||||
|
||||
; Return true if element is a member of the set.
|
||||
(defun set-member (set element)
|
||||
(gethash element (set-elts-hash set)))
|
||||
|
||||
|
||||
; Return the set as a list.
|
||||
(defun set-elements (set)
|
||||
(let ((elements nil))
|
||||
(maphash #'(lambda (key value)
|
||||
(declare (ignore value))
|
||||
(push key elements))
|
||||
(set-elts-hash set))
|
||||
elements))
|
||||
|
||||
|
||||
; Print the set
|
||||
(defmethod print-object ((set set) stream)
|
||||
(if *print-readably*
|
||||
(call-next-method)
|
||||
(format stream "~<{~;~@{~W ~:_~}~;}~:>" (set-elements set))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; DEPTH-FIRST SEARCH
|
||||
|
||||
; Return a depth-first-ordered list of the nodes in a directed graph.
|
||||
; The graph may contain cycles, so a general depth-first search is used.
|
||||
; start is the start node.
|
||||
; successors is a function that takes a node and returns a list of that
|
||||
; node's successors.
|
||||
; test is a function that takes two nodes and returns true if they are
|
||||
; the same node. test should be either #'eq, #'eql, or #'equal
|
||||
; because it is used as a test function in a hash table.
|
||||
(defun depth-first-search (test successors start)
|
||||
(let ((visited-nodes (make-set test))
|
||||
(dfs-list nil))
|
||||
(labels
|
||||
((visit (node)
|
||||
(set-add visited-nodes node)
|
||||
(dolist (successor (funcall successors node))
|
||||
(unless (set-member visited-nodes successor)
|
||||
(visit successor)))
|
||||
(push node dfs-list)))
|
||||
(visit start)
|
||||
dfs-list)))
|
||||
|
|
@ -0,0 +1,64 @@
|
|||
.title1 {font-family: "Times New Roman", Times, serif; font-size: 36pt; font-weight: bold; color: #000000; white-space: nowrap}
|
||||
|
||||
.title2 {font-family: "Times New Roman", Times, serif; font-size: 18pt; font-weight: bold; color: #000000; white-space: nowrap}
|
||||
|
||||
.top-title {color: #009900}
|
||||
|
||||
.sub {font-size: 50%}
|
||||
|
||||
.sub-num {font-size: smaller; font-style: normal}
|
||||
|
||||
.syntax {margin-left: 0.5in}
|
||||
|
||||
.issue {color: #FF0000}
|
||||
|
||||
|
||||
|
||||
.grammar-rule {margin-left: 18pt; margin-top: 6pt; margin-bottom: 6pt}
|
||||
|
||||
.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}
|
||||
|
||||
|
||||
|
||||
.symbol {font-family: "Symbol"}
|
||||
|
||||
VAR {font-family: Georgia, Palatino, "Times New Roman", Times, serif; font-weight: normal; font-style: italic}
|
||||
|
||||
CODE {font-family: "Courier New", Courier, mono; color: #0000FF}
|
||||
|
||||
PRE {font-family: "Courier New", Courier, mono; color: #0000FF; margin-left: 0.5in}
|
||||
|
||||
.control {font-family: "Times New Roman", Times, serif; font-weight: normal; color: #000099}
|
||||
|
||||
.terminal {font-family: Georgia, Palatino, "Times New Roman", Times, serif; font-weight: bold; color: #009999}
|
||||
|
||||
.terminal-keyword {font-weight: bold}
|
||||
|
||||
.nonterminal {color: #009900}
|
||||
|
||||
.nonterminal-attribute {font-style: normal}
|
||||
|
||||
.nonterminal-argument {font-style: normal}
|
||||
|
||||
.semantic-keyword {font-family: "Times New Roman", Times, serif; font-weight: bold}
|
||||
|
||||
.type-expression {font-family: "Times New Roman", Times, serif; color: #CC0000}
|
||||
|
||||
.type-name {font-family: "Times New Roman", Times, serif; font-variant: small-caps; color: #CC0000}
|
||||
|
||||
.field-name {font-family: Arial, Helvetica, sans-serif; color: #FF0000}
|
||||
|
||||
.global-variable {font-family: "Times New Roman", Times, serif; color: #006600}
|
||||
|
||||
.local-variable {font-family: "Times New Roman", Times, serif; color: #009900}
|
||||
|
||||
.action-name {font-family: "Zapf Chancery", "Comic Sans MS", Script, serif; color: #660066}
|
||||
|
||||
Разница между файлами не показана из-за своего большого размера
Загрузить разницу
|
|
@ -0,0 +1,998 @@
|
|||
;;; The contents of this file are subject to the Netscape Public License
|
||||
;;; Version 1.0 (the "NPL"); you may not use this file except in
|
||||
;;; compliance with the NPL. You may obtain a copy of the NPL at
|
||||
;;; http://www.mozilla.org/NPL/
|
||||
;;;
|
||||
;;; Software distributed under the NPL is distributed on an "AS IS" basis,
|
||||
;;; WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
|
||||
;;; for the specific language governing rights and limitations under the
|
||||
;;; NPL.
|
||||
;;;
|
||||
;;; The Initial Developer of this code under the NPL is Netscape
|
||||
;;; Communications Corporation. Portions created by Netscape are
|
||||
;;; Copyright (C) 1998 Netscape Communications Corporation. All Rights
|
||||
;;; Reserved.
|
||||
|
||||
;;;
|
||||
;;; ECMAScript semantic calculus markup emitters
|
||||
;;;
|
||||
;;; Waldemar Horwat (waldemar@netscape.com)
|
||||
;;;
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; SEMANTIC DEPICTION UTILITIES
|
||||
|
||||
(defparameter *semantic-keywords*
|
||||
'(not and or is type oneof tuple action lambda if then else in new case of end let letexc))
|
||||
|
||||
; Emit markup for one of the semantic keywords, as specified by keyword-symbol.
|
||||
(defun depict-semantic-keyword (markup-stream keyword-symbol)
|
||||
(assert-true (find keyword-symbol *semantic-keywords* :test #'eq))
|
||||
(depict-char-style (markup-stream :semantic-keyword)
|
||||
(depict markup-stream (string-downcase (symbol-name keyword-symbol)))))
|
||||
|
||||
|
||||
; If test is true, depict an opening parenthesis, evaluate body, and depict a closing
|
||||
; parentheses. Otherwise, just evaluate body.
|
||||
; Return the result value of body.
|
||||
(defmacro depict-optional-parentheses ((markup-stream test) &body body)
|
||||
(let ((temp (gensym "PAREN")))
|
||||
`(let ((,temp ,test))
|
||||
(when ,temp
|
||||
(depict ,markup-stream "("))
|
||||
(prog1
|
||||
(progn ,@body)
|
||||
(when ,temp
|
||||
(depict ,markup-stream ")"))))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; DEPICT-ENV
|
||||
|
||||
; A depict-env holds state that helps in depicting a grammar or lexer.
|
||||
(defstruct depict-env
|
||||
(grammar-info nil :type (or null grammar-info)) ;The current grammar-info or nil if none
|
||||
(seen-nonterminals nil :type (or null hash-table)) ;Hash table (nonterminal -> t) of nonterminals already depicted
|
||||
(mode nil :type (member nil :syntax :semantics)) ;Current heading (:syntax or :semantics) or nil if none
|
||||
(pending-actions-reverse nil :type list)) ;Reverse-order list of closures of actions pending for a %print-actions
|
||||
|
||||
|
||||
(defun checked-depict-env-grammar-info (depict-env)
|
||||
(or (depict-env-grammar-info depict-env)
|
||||
(error "Grammar needed")))
|
||||
|
||||
|
||||
(defvar *visible-modes* t)
|
||||
|
||||
; Set the mode to the given mode, emitting a heading if necessary.
|
||||
(defun depict-mode (markup-stream depict-env mode)
|
||||
(unless (eq mode (depict-env-mode depict-env))
|
||||
(when *visible-modes*
|
||||
(ecase mode
|
||||
(:syntax (depict-paragraph (markup-stream ':grammar-header)
|
||||
(depict markup-stream "Syntax")))
|
||||
(:semantics (depict-paragraph (markup-stream ':grammar-header)
|
||||
(depict markup-stream "Semantics")))
|
||||
((nil))))
|
||||
(setf (depict-env-mode depict-env) mode)))
|
||||
|
||||
|
||||
; Emit markup paragraphs for a command.
|
||||
(defun depict-command (markup-stream world depict-env command)
|
||||
(handler-bind ((error #'(lambda (condition)
|
||||
(declare (ignore condition))
|
||||
(format *error-output* "~&While depicting: ~:W~%" command))))
|
||||
(let ((depictor (and (consp command)
|
||||
(identifier? (first command))
|
||||
(get (world-intern world (first command)) :depict-command))))
|
||||
(if depictor
|
||||
(apply depictor markup-stream world depict-env (rest command))
|
||||
(error "Bad command: ~S" command)))))
|
||||
|
||||
|
||||
; Emit markup paragraphs for the world's commands.
|
||||
(defun depict-world-commands (markup-stream world)
|
||||
(let ((depict-env (make-depict-env)))
|
||||
(dolist (command (world-commands-source world))
|
||||
(depict-command markup-stream world depict-env command))
|
||||
(depict-clear-grammar markup-stream world depict-env)))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; DEPICTING TYPES
|
||||
|
||||
(defconstant *type-level-min* 0)
|
||||
(defconstant *type-level-suffix* 1)
|
||||
(defconstant *type-level-function* 2)
|
||||
(defconstant *type-level-max* 2)
|
||||
;;;
|
||||
;;; The level argument indicates what kinds of component types may be represented without being placed
|
||||
;;; in parentheses.
|
||||
;;; level kinds
|
||||
;;; 0 id, oneof, tuple, (type)
|
||||
;;; 1 id, oneof, tuple, (type), type[], type^
|
||||
;;; 2 id, oneof, tuple, (type), type[], type^, type x type -> type
|
||||
|
||||
|
||||
; Emit markup for the name of a type, which must be a symbol.
|
||||
(defun depict-type-name (markup-stream type-name)
|
||||
(depict-char-style (markup-stream :type-name)
|
||||
(depict markup-stream (symbol-upper-mixed-case-name type-name))))
|
||||
|
||||
|
||||
; Emit markup for the name of a tuple or oneof field, which must be a symbol.
|
||||
(defun depict-field-name (markup-stream field-name)
|
||||
(depict-char-style (markup-stream :field-name)
|
||||
(depict markup-stream (symbol-lower-mixed-case-name field-name))))
|
||||
|
||||
|
||||
; If level < threshold, depict an opening parenthesis, evaluate body, and depict a closing
|
||||
; parentheses. Otherwise, just evaluate body.
|
||||
; Return the result value of body.
|
||||
(defmacro depict-type-parentheses ((markup-stream level threshold) &body body)
|
||||
`(depict-optional-parentheses (,markup-stream (< ,level ,threshold))
|
||||
,@body))
|
||||
|
||||
|
||||
; Emit markup for the given type expression. level is non-nil if this is a recursive
|
||||
; call to depict-type-expr for which the markup-stream's style is :type-expression.
|
||||
; In this case level indicates the binding level imposed by the enclosing type expression.
|
||||
(defun depict-type-expr (markup-stream world type-expr &optional level)
|
||||
(cond
|
||||
((identifier? type-expr)
|
||||
(depict-type-name markup-stream type-expr))
|
||||
((type? type-expr)
|
||||
(let ((type-str (print-type-to-string type-expr)))
|
||||
(warn "Depicting raw type ~A" type-str)
|
||||
(depict markup-stream "<<<" type-str ">>>")))
|
||||
(t (let ((depictor (get (world-intern world (first type-expr)) :depict-type-constructor)))
|
||||
(if level
|
||||
(apply depictor markup-stream world level (rest type-expr))
|
||||
(depict-char-style (markup-stream :type-expression)
|
||||
(apply depictor markup-stream world *type-level-max* (rest type-expr))))))))
|
||||
|
||||
|
||||
; (-> (<arg-type1> ... <arg-typen>) <result-type>)
|
||||
; Level 2
|
||||
; "<arg-type1>@1 x ... x <arg-typen>@1 -> <result-type>@1"
|
||||
(defun depict--> (markup-stream world level arg-type-exprs result-type-expr)
|
||||
(depict-type-parentheses (markup-stream level *type-level-function*)
|
||||
(depict-list markup-stream
|
||||
#'(lambda (markup-stream arg-type-expr)
|
||||
(depict-type-expr markup-stream world arg-type-expr *type-level-suffix*))
|
||||
arg-type-exprs
|
||||
:separator '(" " :cartesian-product-10 " ")
|
||||
:empty "()")
|
||||
(depict markup-stream " " :function-arrow-10 " ")
|
||||
(depict-type-expr markup-stream world result-type-expr *type-level-suffix*)))
|
||||
|
||||
|
||||
; (vector <element-type>)
|
||||
; Level 1
|
||||
; "<element-type>@1[]"
|
||||
(defun depict-vector (markup-stream world level element-type-expr)
|
||||
(depict-type-parentheses (markup-stream level *type-level-suffix*)
|
||||
(depict-type-expr markup-stream world element-type-expr *type-level-suffix*)
|
||||
(depict markup-stream "[]")))
|
||||
|
||||
|
||||
; (address <element-type>)
|
||||
; Level 1
|
||||
; "<element-type>@1^"
|
||||
(defun depict-address (markup-stream world level element-type-expr)
|
||||
(depict-type-parentheses (markup-stream level *type-level-suffix*)
|
||||
(depict-type-expr markup-stream world element-type-expr *type-level-suffix*)
|
||||
(depict markup-stream :up-arrow-10)))
|
||||
|
||||
|
||||
(defun depict-tuple-or-oneof (markup-stream world keyword-symbol tag-pairs)
|
||||
(depict-semantic-keyword markup-stream keyword-symbol)
|
||||
(depict-list
|
||||
markup-stream
|
||||
#'(lambda (markup-stream tag-pair)
|
||||
(if (identifier? tag-pair)
|
||||
(depict-field-name markup-stream tag-pair)
|
||||
(progn
|
||||
(depict-field-name markup-stream (first tag-pair))
|
||||
(depict markup-stream ": ")
|
||||
(depict-type-expr markup-stream world (second tag-pair) *type-level-function*))))
|
||||
tag-pairs
|
||||
:indent 6
|
||||
:prefix " {"
|
||||
:prefix-break 0
|
||||
:suffix "}"
|
||||
:separator ";"
|
||||
:break 1
|
||||
:empty nil))
|
||||
|
||||
; (oneof (<tag1> <type1>) ... (<tagn> <typen>))
|
||||
; Level 0
|
||||
; "ONEOF{<tag1>: <type1>@0; ...; <tagn>:<typen>@0}"
|
||||
(defun depict-oneof (markup-stream world level &rest tags-and-types)
|
||||
(declare (ignore level))
|
||||
(depict-tuple-or-oneof markup-stream world 'oneof tags-and-types))
|
||||
|
||||
; (tuple (<tag1> <type1>) ... (<tagn> <typen>))
|
||||
; Level 0
|
||||
; "TUPLE{<tag1>: <type1>@0; ...; <tagn>:<typen>@0}"
|
||||
(defun depict-tuple (markup-stream world level &rest tags-and-types)
|
||||
(declare (ignore level))
|
||||
(depict-tuple-or-oneof markup-stream world 'tuple tags-and-types))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; DEPICTING EXPRESSIONS
|
||||
|
||||
|
||||
(defconstant *primitive-level-min* 0)
|
||||
(defconstant *primitive-level-unary-suffix* 1)
|
||||
(defconstant *primitive-level-unary-prefix* 2)
|
||||
(defconstant *primitive-level-unary* 3)
|
||||
(defconstant *primitive-level-multiplicative* 4)
|
||||
(defconstant *primitive-level-additive* 5)
|
||||
(defconstant *primitive-level-relational* 6)
|
||||
(defconstant *primitive-level-logical* 7)
|
||||
(defconstant *primitive-level-unparenthesized-new* 8)
|
||||
(defconstant *primitive-level-expr* 9)
|
||||
(defconstant *primitive-level-stmt* 10)
|
||||
(defconstant *primitive-level-max* 10)
|
||||
;;;
|
||||
;;; The level argument indicates what kinds of subexpressions may be represented without being placed
|
||||
;;; in parentheses (or on a separate line for the case of lambda and if/then/else).
|
||||
;;; level kinds
|
||||
;;; 0 id, constant, (e)
|
||||
;;; 1 id, constant, (e), f(...), new(v), a[i]
|
||||
;;; 2 id, constant, (e), -e, @
|
||||
;;; 3 id, constant, (e), f(...), new(v), a[i], -e, @
|
||||
;;; 4 id, constant, (e), f(...), new(v), a[i], -e, @, /, *
|
||||
;;; 5 id, constant, (e), f(...), new(v), a[i], -e, @, /, *, +, -
|
||||
;;; 6 id, constant, (e), f(...), new(v), a[i], -e, @, /, *, +, -, relationals
|
||||
;;; 7 id, constant, (e), f(...), new(v), a[i], -e, @, /, *, +, -, relationals, logicals
|
||||
;;; 8 id, constant, (e), f(...), new(v), a[i], -e, @, /, *, +, -, relationals, logicals, new v
|
||||
;;; 9 id, constant, (e), f(...), new(v), a[i], -e, @, /, *, +, -, relationals, logicals, new v
|
||||
;;; 10 id, constant, (e), f(...), new(v), a[i], -e, @, /, *, +, -, relationals, logicals, new v, :=, lambda, if/then/else
|
||||
|
||||
; Return true if primitive-level1 is a superset of primitive-level2
|
||||
; in the partial order of primitive levels.
|
||||
(defun primitive-level->= (primitive-level1 primitive-level2)
|
||||
(and (>= primitive-level1 primitive-level2)
|
||||
(or (/= primitive-level1 *primitive-level-unary-prefix*)
|
||||
(/= primitive-level2 *primitive-level-unary-suffix*))))
|
||||
|
||||
|
||||
; If primitive-level is not a superset of threshold, depict an opening parenthesis,
|
||||
; evaluate body, and depict a closing parentheses. Otherwise, just evaluate body.
|
||||
; Return the result value of body.
|
||||
(defmacro depict-expr-parentheses ((markup-stream primitive-level threshold) &body body)
|
||||
`(depict-optional-parentheses (,markup-stream (not (primitive-level->= ,primitive-level ,threshold)))
|
||||
,@body))
|
||||
|
||||
|
||||
; Emit markup for the name of a global variable, which must be a symbol.
|
||||
(defun depict-global-variable (markup-stream name)
|
||||
(depict-char-style (markup-stream :global-variable)
|
||||
(depict markup-stream (symbol-lower-mixed-case-name name))))
|
||||
|
||||
|
||||
; Emit markup for the name of a local variable, which must be a symbol.
|
||||
(defun depict-local-variable (markup-stream name)
|
||||
(depict-char-style (markup-stream :local-variable)
|
||||
(depict markup-stream (symbol-lower-mixed-case-name name))))
|
||||
|
||||
|
||||
; Emit markup for the name of an action, which must be a symbol.
|
||||
(defun depict-action-name (markup-stream action-name)
|
||||
(depict-char-style (markup-stream :action-name)
|
||||
(depict markup-stream (symbol-upper-mixed-case-name action-name))))
|
||||
|
||||
|
||||
; Emit markup for the value constant.
|
||||
(defun depict-constant (markup-stream constant)
|
||||
(cond
|
||||
((integerp constant)
|
||||
(depict-integer markup-stream constant))
|
||||
((floatp constant)
|
||||
(depict markup-stream (format nil (if (= constant (floor constant 1)) "~,1F" "~F") constant)))
|
||||
((characterp constant)
|
||||
(depict markup-stream ':left-single-quote)
|
||||
(depict-char-style (markup-stream ':character-literal)
|
||||
(depict-character markup-stream constant nil))
|
||||
(depict markup-stream ':right-single-quote))
|
||||
((stringp constant)
|
||||
(depict-string markup-stream constant))
|
||||
(t (error "Bad constant ~S" constant))))
|
||||
|
||||
|
||||
; Emit markup for the primitive when it is not called in a function call.
|
||||
(defun depict-primitive (markup-stream primitive)
|
||||
(unless (eq (primitive-appearance primitive) ':global)
|
||||
(error "Can't depict primitive ~S outside a call" primitive))
|
||||
(depict-item-or-group-list markup-stream (primitive-markup1 primitive)))
|
||||
|
||||
|
||||
; Emit markup for the parameters to a function call.
|
||||
(defun depict-call-parameters (markup-stream world annotated-parameters)
|
||||
(depict-list markup-stream
|
||||
#'(lambda (markup-stream parameter)
|
||||
(depict-annotated-value-expr markup-stream world parameter))
|
||||
annotated-parameters
|
||||
:indent 4
|
||||
:prefix "("
|
||||
:prefix-break 0
|
||||
:suffix ")"
|
||||
:separator ","
|
||||
:break 1
|
||||
:empty nil))
|
||||
|
||||
|
||||
; Emit markup for the function or primitive call. level indicates the binding level imposed
|
||||
; by the enclosing expression.
|
||||
(defun depict-call (markup-stream world level annotated-function-expr &rest annotated-arg-exprs)
|
||||
(if (eq (first annotated-function-expr) 'expr-annotation:primitive)
|
||||
(let ((primitive (symbol-primitive (second annotated-function-expr))))
|
||||
(depict-expr-parentheses (markup-stream level (primitive-level primitive))
|
||||
(ecase (primitive-appearance primitive)
|
||||
(:global
|
||||
(depict-primitive markup-stream primitive)
|
||||
(depict-call-parameters markup-stream world annotated-arg-exprs))
|
||||
(:infix
|
||||
(assert-true (= (length annotated-arg-exprs) 2))
|
||||
(depict-logical-block (markup-stream 0)
|
||||
(depict-annotated-value-expr markup-stream world (first annotated-arg-exprs) (primitive-level1 primitive))
|
||||
(let ((spaces (primitive-markup2 primitive)))
|
||||
(when spaces
|
||||
(depict-space markup-stream))
|
||||
(depict-item-or-group-list markup-stream (primitive-markup1 primitive))
|
||||
(depict-break markup-stream (if spaces 1 0)))
|
||||
(depict-annotated-value-expr markup-stream world (second annotated-arg-exprs) (primitive-level2 primitive))))
|
||||
(:unary
|
||||
(assert-true (= (length annotated-arg-exprs) 1))
|
||||
(depict-item-or-group-list markup-stream (primitive-markup1 primitive))
|
||||
(depict-annotated-value-expr markup-stream world (first annotated-arg-exprs) (primitive-level1 primitive))
|
||||
(depict-item-or-group-list markup-stream (primitive-markup2 primitive)))
|
||||
(:phantom
|
||||
(assert-true (= (length annotated-arg-exprs) 1))
|
||||
(depict-annotated-value-expr markup-stream world (first annotated-arg-exprs) level)))))
|
||||
(depict-expr-parentheses (markup-stream level *primitive-level-unary-suffix*)
|
||||
(depict-annotated-value-expr markup-stream world annotated-function-expr *primitive-level-unary-suffix*)
|
||||
(depict-call-parameters markup-stream world annotated-arg-exprs))))
|
||||
|
||||
|
||||
; Emit markup for the reference to the action on the given general grammar symbol.
|
||||
(defun depict-action-reference (markup-stream action-name general-grammar-symbol &optional index)
|
||||
(depict-action-name markup-stream action-name)
|
||||
(depict markup-stream :action-begin)
|
||||
(depict-general-grammar-symbol markup-stream general-grammar-symbol index)
|
||||
(depict markup-stream :action-end))
|
||||
|
||||
|
||||
; Emit markup for the given annotated value expression. level indicates the binding level imposed
|
||||
; by the enclosing expression.
|
||||
(defun depict-annotated-value-expr (markup-stream world annotated-expr &optional (level *primitive-level-expr*))
|
||||
(let ((annotation (first annotated-expr))
|
||||
(args (rest annotated-expr)))
|
||||
(ecase annotation
|
||||
(expr-annotation:constant (depict-constant markup-stream (first args)))
|
||||
(expr-annotation:primitive (depict-primitive markup-stream (symbol-primitive (first args))))
|
||||
(expr-annotation:local (depict-local-variable markup-stream (first args)))
|
||||
(expr-annotation:global (depict-global-variable markup-stream (first args)))
|
||||
(expr-annotation:call (apply #'depict-call markup-stream world level args))
|
||||
(expr-annotation:action (apply #'depict-action-reference markup-stream args))
|
||||
(expr-annotation:special-form
|
||||
(apply (get (first args) :depict-special-form) markup-stream world level (rest args)))
|
||||
(expr-annotation:macro
|
||||
(let ((depictor (get (first args) :depict-macro)))
|
||||
(if depictor
|
||||
(apply depictor markup-stream world level (rest args))
|
||||
(depict-annotated-value-expr markup-stream world (second args) level)))))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; DEPICTING SPECIAL FORMS
|
||||
|
||||
(defmacro depict-statement ((markup-stream keyword &optional (space t)) &body body)
|
||||
`(depict-logical-block (,markup-stream 0)
|
||||
(when (< level *primitive-level-stmt*)
|
||||
(depict-break ,markup-stream))
|
||||
(depict-expr-parentheses (,markup-stream level *primitive-level-stmt*)
|
||||
(depict-semantic-keyword ,markup-stream ,keyword)
|
||||
,@(and space `((depict-space ,markup-stream)))
|
||||
,@body)))
|
||||
|
||||
|
||||
; (bottom <type>)
|
||||
(defun depict-bottom (markup-stream world level type-expr)
|
||||
(declare (ignore world level type-expr))
|
||||
(depict markup-stream ':bottom-10))
|
||||
|
||||
|
||||
(defun depict-lambda-bindings (markup-stream world arg-binding-exprs)
|
||||
(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
|
||||
:prefix "("
|
||||
:suffix ")"
|
||||
:separator ", "
|
||||
:empty nil))
|
||||
|
||||
; (lambda ((<var1> <type1> [:unused]) ... (<varn> <typen> [:unused])) <body>)
|
||||
(defun depict-lambda (markup-stream world level arg-binding-exprs body-annotated-expr)
|
||||
(depict-statement (markup-stream 'lambda nil)
|
||||
(depict-lambda-bindings markup-stream world arg-binding-exprs)
|
||||
(depict-logical-block (markup-stream 4)
|
||||
(depict-break markup-stream)
|
||||
(depict-annotated-value-expr markup-stream world body-annotated-expr *primitive-level-stmt*))))
|
||||
|
||||
|
||||
; (if <condition-expr> <true-expr> <false-expr>)
|
||||
(defun depict-if (markup-stream world level condition-annotated-expr true-annotated-expr false-annotated-expr)
|
||||
(depict-statement (markup-stream 'if)
|
||||
(depict-logical-block (markup-stream 4)
|
||||
(depict-annotated-value-expr markup-stream world condition-annotated-expr))
|
||||
(depict-break markup-stream)
|
||||
(depict-semantic-keyword markup-stream 'then)
|
||||
(depict-space markup-stream)
|
||||
(depict-logical-block (markup-stream 7)
|
||||
(depict-annotated-value-expr markup-stream world true-annotated-expr *primitive-level-stmt*))
|
||||
(depict-break markup-stream)
|
||||
(depict-semantic-keyword markup-stream 'else)
|
||||
(depict-space markup-stream)
|
||||
(depict-logical-block (markup-stream (if (special-form-annotated-expr? 'if false-annotated-expr) nil 6))
|
||||
(depict-annotated-value-expr markup-stream world false-annotated-expr *primitive-level-stmt*))))
|
||||
|
||||
|
||||
;;; Vectors
|
||||
|
||||
; (vector <element-expr> <element-expr> ... <element-expr>)
|
||||
(defun depict-vector-form (markup-stream world level &rest element-annotated-exprs)
|
||||
(declare (ignore level))
|
||||
(depict-list markup-stream
|
||||
#'(lambda (markup-stream element-annotated-expr)
|
||||
(depict-annotated-value-expr markup-stream world element-annotated-expr))
|
||||
element-annotated-exprs
|
||||
:indent 1
|
||||
:prefix ':vector-begin
|
||||
:suffix ':vector-end
|
||||
:separator ","
|
||||
:break 1))
|
||||
|
||||
|
||||
(defun depict-subscript-type-expr (markup-stream world type-expr)
|
||||
(depict-char-style (markup-stream 'sub)
|
||||
(depict-type-expr markup-stream world type-expr)))
|
||||
|
||||
|
||||
; (vector-of <element-type>)
|
||||
(defun depict-vector-of (markup-stream world level element-type-expr)
|
||||
(declare (ignore level))
|
||||
(depict markup-stream ':empty-vector)
|
||||
(depict-subscript-type-expr markup-stream world element-type-expr))
|
||||
|
||||
|
||||
(defun depict-special-function (markup-stream world name-str &rest arg-annotated-exprs)
|
||||
(depict-char-style (markup-stream :global-variable)
|
||||
(depict markup-stream name-str))
|
||||
(depict-call-parameters markup-stream world arg-annotated-exprs))
|
||||
|
||||
|
||||
; (empty <vector-expr>)
|
||||
(defun depict-empty (markup-stream world level vector-annotated-expr)
|
||||
(declare (ignore level))
|
||||
(depict-special-function markup-stream world "empty" vector-annotated-expr))
|
||||
|
||||
|
||||
; (length <vector-expr>)
|
||||
(defun depict-length (markup-stream world level vector-annotated-expr)
|
||||
(declare (ignore level))
|
||||
(depict-special-function markup-stream world "length" vector-annotated-expr))
|
||||
|
||||
|
||||
; (first <vector-expr>)
|
||||
(defun depict-first (markup-stream world level vector-annotated-expr)
|
||||
(declare (ignore level))
|
||||
(depict-special-function markup-stream world "first" vector-annotated-expr))
|
||||
|
||||
|
||||
; (last <vector-expr>)
|
||||
(defun depict-last (markup-stream world level vector-annotated-expr)
|
||||
(declare (ignore level))
|
||||
(depict-special-function markup-stream world "last" vector-annotated-expr))
|
||||
|
||||
|
||||
; (rest <vector-expr>)
|
||||
(defun depict-rest (markup-stream world level vector-annotated-expr)
|
||||
(declare (ignore level))
|
||||
(depict-special-function markup-stream world "rest" vector-annotated-expr))
|
||||
|
||||
|
||||
; (butlast <vector-expr>)
|
||||
(defun depict-butlast (markup-stream world level vector-annotated-expr)
|
||||
(declare (ignore level))
|
||||
(depict-special-function markup-stream world "butLast" vector-annotated-expr))
|
||||
|
||||
|
||||
; (nth <vector-expr> <n-expr>)
|
||||
(defun depict-nth (markup-stream world level vector-annotated-expr n-annotated-expr)
|
||||
(depict-expr-parentheses (markup-stream level *primitive-level-unary-suffix*)
|
||||
(depict-annotated-value-expr markup-stream world vector-annotated-expr *primitive-level-unary-suffix*)
|
||||
(depict markup-stream "[")
|
||||
(depict-annotated-value-expr markup-stream world n-annotated-expr)
|
||||
(depict markup-stream "]")))
|
||||
|
||||
|
||||
; (append <vector-expr> <vector-expr>)
|
||||
(defun depict-append (markup-stream world level vector1-annotated-expr vector2-annotated-expr)
|
||||
(depict-expr-parentheses (markup-stream level *primitive-level-additive*)
|
||||
(depict-logical-block (markup-stream 0)
|
||||
(depict-annotated-value-expr markup-stream world vector1-annotated-expr *primitive-level-additive*)
|
||||
(depict markup-stream " " :vector-append)
|
||||
(depict-break markup-stream 1)
|
||||
(depict-annotated-value-expr markup-stream world vector2-annotated-expr *primitive-level-additive*))))
|
||||
|
||||
|
||||
;;; Oneofs
|
||||
|
||||
; (oneof <oneof-type> <tag> <value-expr>)
|
||||
(defun depict-oneof-form (markup-stream world level tag &optional value-annotated-expr)
|
||||
(depict-expr-parentheses (markup-stream level *primitive-level-unary-prefix*)
|
||||
(depict-field-name markup-stream tag)
|
||||
(when value-annotated-expr
|
||||
(depict-logical-block (markup-stream 4)
|
||||
(depict-break markup-stream 1)
|
||||
(depict-annotated-value-expr markup-stream world value-annotated-expr *primitive-level-unary*)))))
|
||||
|
||||
|
||||
; (typed-oneof <type-expr> <tag> <value-expr>)
|
||||
(defun depict-typed-oneof (markup-stream world level type-expr tag &optional value-annotated-expr)
|
||||
(depict-expr-parentheses (markup-stream level *primitive-level-unary-prefix*)
|
||||
(depict-field-name markup-stream tag)
|
||||
(depict-subscript-type-expr markup-stream world type-expr)
|
||||
(when value-annotated-expr
|
||||
(depict-logical-block (markup-stream 4)
|
||||
(depict-break markup-stream 1)
|
||||
(depict-annotated-value-expr markup-stream world value-annotated-expr *primitive-level-unary*)))))
|
||||
|
||||
|
||||
; (case <oneof-expr> (<tag-spec> <value-expr>) (<tag-spec> <value-expr>) ... (<tag-spec> <value-expr>))
|
||||
; where each <tag-spec> is either ((<tag> <tag> ... <tag>) nil nil) or ((<tag>) <var> <type>)
|
||||
(defun depict-case (markup-stream world level oneof-annotated-expr &rest annotated-cases)
|
||||
(depict-statement (markup-stream 'case)
|
||||
(depict-logical-block (markup-stream 6)
|
||||
(depict-annotated-value-expr markup-stream world oneof-annotated-expr))
|
||||
(depict-space markup-stream)
|
||||
(depict-semantic-keyword markup-stream 'of)
|
||||
(depict-logical-block (markup-stream 3)
|
||||
(mapl #'(lambda (annotated-cases)
|
||||
(let* ((annotated-case (first annotated-cases))
|
||||
(tag-spec (first annotated-case))
|
||||
(tags (first tag-spec))
|
||||
(var (second tag-spec))
|
||||
(value-annotated-expr (second annotated-case)))
|
||||
(depict-break markup-stream)
|
||||
(depict-logical-block (markup-stream 6)
|
||||
(depict-list markup-stream
|
||||
#'depict-field-name
|
||||
tags
|
||||
:indent 0
|
||||
:separator ","
|
||||
:break 1)
|
||||
(when var
|
||||
(depict markup-stream "(")
|
||||
(depict-local-variable markup-stream var)
|
||||
(depict markup-stream ": ")
|
||||
(depict-type-expr markup-stream world (third tag-spec))
|
||||
(depict markup-stream ")"))
|
||||
(depict markup-stream ":")
|
||||
(depict-break markup-stream 1)
|
||||
(depict-annotated-value-expr markup-stream world value-annotated-expr *primitive-level-stmt*)
|
||||
(when (cdr annotated-cases)
|
||||
(depict markup-stream ";")))))
|
||||
annotated-cases)
|
||||
(depict-break markup-stream)
|
||||
(depict-semantic-keyword markup-stream 'end))))
|
||||
|
||||
|
||||
; (select <tag> <oneof-expr>)
|
||||
; (& <tag> <tuple-expr>)
|
||||
(defun depict-select-or-& (markup-stream world level tag annotated-expr)
|
||||
(depict-expr-parentheses (markup-stream level *primitive-level-unary-suffix*)
|
||||
(depict-annotated-value-expr markup-stream world annotated-expr *primitive-level-unary-suffix*)
|
||||
(depict markup-stream ".")
|
||||
(depict-field-name markup-stream tag)))
|
||||
|
||||
|
||||
; (is <tag> <oneof-expr>)
|
||||
(defun depict-is (markup-stream world level tag oneof-annotated-expr)
|
||||
(depict-expr-parentheses (markup-stream level *primitive-level-relational*)
|
||||
(depict-annotated-value-expr markup-stream world oneof-annotated-expr *primitive-level-unary-suffix*)
|
||||
(depict-space markup-stream)
|
||||
(depict-semantic-keyword markup-stream 'is)
|
||||
(depict-space markup-stream)
|
||||
(depict-field-name markup-stream tag)))
|
||||
|
||||
|
||||
;;; Tuples
|
||||
|
||||
; (tuple <tuple-type> <field-expr1> ... <field-exprn>)
|
||||
(defun depict-tuple-form (markup-stream world level type-expr &rest annotated-exprs)
|
||||
(declare (ignore level))
|
||||
(depict-list markup-stream
|
||||
#'(lambda (markup-stream parameter)
|
||||
(depict-annotated-value-expr markup-stream world parameter))
|
||||
annotated-exprs
|
||||
:indent 4
|
||||
:prefix ':tuple-begin
|
||||
:prefix-break 0
|
||||
:suffix ':tuple-end
|
||||
:separator ","
|
||||
:break 1
|
||||
:empty nil)
|
||||
(depict-subscript-type-expr markup-stream world type-expr))
|
||||
|
||||
|
||||
;;; Addresses
|
||||
|
||||
; (new <value-expr>)
|
||||
(defun depict-new (markup-stream world level value-annotated-expr)
|
||||
(depict-logical-block (markup-stream 5)
|
||||
(depict-semantic-keyword markup-stream 'new)
|
||||
(depict-space markup-stream)
|
||||
(depict-expr-parentheses (markup-stream level *primitive-level-unparenthesized-new*)
|
||||
(depict-annotated-value-expr markup-stream world value-annotated-expr
|
||||
(if (< level *primitive-level-unparenthesized-new*)
|
||||
*primitive-level-expr*
|
||||
*primitive-level-unary-prefix*)))))
|
||||
|
||||
|
||||
; (@ <address-expr>)
|
||||
(defun depict-@ (markup-stream world level address-annotated-expr)
|
||||
(depict-expr-parentheses (markup-stream level *primitive-level-unary-prefix*)
|
||||
(depict-logical-block (markup-stream 2)
|
||||
(depict markup-stream "@")
|
||||
(depict-annotated-value-expr markup-stream world address-annotated-expr *primitive-level-unary-prefix*))))
|
||||
|
||||
|
||||
; (@= <address-expr> <value-expr>)
|
||||
(defun depict-@= (markup-stream world level address-annotated-expr value-annotated-expr)
|
||||
(depict-expr-parentheses (markup-stream level *primitive-level-stmt*)
|
||||
(depict-logical-block (markup-stream 0)
|
||||
(depict markup-stream "@")
|
||||
(depict-annotated-value-expr markup-stream world address-annotated-expr *primitive-level-unary-prefix*)
|
||||
(depict markup-stream " :=")
|
||||
(depict-logical-block (markup-stream 6)
|
||||
(depict-break markup-stream 1)
|
||||
(depict-annotated-value-expr markup-stream world value-annotated-expr *primitive-level-stmt*)))))
|
||||
|
||||
|
||||
; (address-equal <address-expr1> <address-expr2>)
|
||||
(defun depict-address-equal (markup-stream world level address1-annotated-expr address2-annotated-expr)
|
||||
(depict-expr-parentheses (markup-stream level *primitive-level-relational*)
|
||||
(depict-logical-block (markup-stream 0)
|
||||
(depict-annotated-value-expr markup-stream world address1-annotated-expr *primitive-level-additive*)
|
||||
(depict markup-stream " " :identical-10)
|
||||
(depict-break markup-stream 1)
|
||||
(depict-annotated-value-expr markup-stream world address2-annotated-expr *primitive-level-additive*))))
|
||||
|
||||
|
||||
;;; Macros
|
||||
|
||||
(defun depict-let-binding (markup-stream world var type-expr value-annotated-expr)
|
||||
(depict-logical-block (markup-stream 4)
|
||||
(depict-local-variable markup-stream var)
|
||||
(depict markup-stream ": ")
|
||||
(depict-type-expr markup-stream world type-expr)
|
||||
(depict-break markup-stream 1)
|
||||
(depict-logical-block (markup-stream 3)
|
||||
(depict markup-stream "= ")
|
||||
(depict-annotated-value-expr markup-stream world value-annotated-expr *primitive-level-stmt*))))
|
||||
|
||||
|
||||
(defun depict-let-body (markup-stream world body-annotated-expr)
|
||||
(depict-break markup-stream)
|
||||
(depict-semantic-keyword markup-stream 'in)
|
||||
(depict-space markup-stream)
|
||||
(depict-logical-block (markup-stream (if (or (macro-annotated-expr? 'let body-annotated-expr)
|
||||
(macro-annotated-expr? 'letexc body-annotated-expr))
|
||||
nil
|
||||
4))
|
||||
(depict-annotated-value-expr markup-stream world body-annotated-expr *primitive-level-stmt*)))
|
||||
|
||||
|
||||
; (let ((<var1> <type1> <expr1> [:unused]) ... (<varn> <typen> <exprn> [:unused])) <body>) ==>
|
||||
; ((lambda ((<var1> <type1> [:unused]) ... (<varn> <typen> [:unused])) <body>) <expr1> ... <exprn>)
|
||||
(defun depict-let (markup-stream world level annotated-expansion)
|
||||
(assert-true (eq (first annotated-expansion) 'expr-annotation:call))
|
||||
(let ((lambda-annotated-expr (second annotated-expansion))
|
||||
(arg-annotated-exprs (cddr annotated-expansion)))
|
||||
(assert-true (special-form-annotated-expr? 'lambda lambda-annotated-expr))
|
||||
(let ((arg-binding-exprs (third lambda-annotated-expr))
|
||||
(body-annotated-expr (fourth lambda-annotated-expr)))
|
||||
(depict-statement (markup-stream 'let)
|
||||
(depict-list markup-stream
|
||||
#'(lambda (markup-stream arg-binding)
|
||||
(depict-let-binding markup-stream world (first arg-binding) (second arg-binding) (pop arg-annotated-exprs)))
|
||||
arg-binding-exprs
|
||||
:indent 4
|
||||
:separator ";"
|
||||
:break t
|
||||
:empty nil)
|
||||
(depict-let-body markup-stream world body-annotated-expr)))))
|
||||
|
||||
|
||||
; (letexc (<var> <type> <expr> [:unused]) <body>) ==>
|
||||
; (case <expr>
|
||||
; ((abrupt x exception) (typed-oneof <body-type> abrupt x))
|
||||
; ((normal <var> <type> [:unused]) <body>)))
|
||||
(defun depict-letexc (markup-stream world level annotated-expansion)
|
||||
(assert-true (special-form-annotated-expr? 'case annotated-expansion))
|
||||
(let* ((expr-annotated-expr (third annotated-expansion))
|
||||
(abrupt-binding (fourth annotated-expansion))
|
||||
(abrupt-tag-spec (first abrupt-binding))
|
||||
(normal-binding (fifth annotated-expansion))
|
||||
(normal-tag-spec (first normal-binding)))
|
||||
(assert-true (equal (first abrupt-tag-spec) '(abrupt)))
|
||||
(assert-true (equal (first normal-tag-spec) '(normal)))
|
||||
(let* ((var (second normal-tag-spec))
|
||||
(type-expr (third normal-tag-spec))
|
||||
(body-annotated-expr (second normal-binding)))
|
||||
(depict-statement (markup-stream 'letexc)
|
||||
(depict-logical-block (markup-stream 9)
|
||||
(depict-let-binding markup-stream world var type-expr expr-annotated-expr))
|
||||
(depict-let-body markup-stream world body-annotated-expr)))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; DEPICTING COMMANDS
|
||||
|
||||
|
||||
(defmacro depict-semantics ((markup-stream depict-env &optional (paragraph-style ':semantics)) &body body)
|
||||
`(progn
|
||||
(depict-mode ,markup-stream ,depict-env :semantics)
|
||||
(depict-paragraph (,markup-stream ,paragraph-style)
|
||||
,@body)))
|
||||
|
||||
|
||||
; (%section "section-name")
|
||||
(defun depict-%section (markup-stream world depict-env section-name)
|
||||
(declare (ignore world))
|
||||
(assert-type section-name string)
|
||||
(depict-mode markup-stream depict-env nil)
|
||||
(depict-paragraph (markup-stream :section-heading)
|
||||
(depict markup-stream section-name)))
|
||||
|
||||
|
||||
; (%subsection "subsection-name")
|
||||
(defun depict-%subsection (markup-stream world depict-env section-name)
|
||||
(declare (ignore world))
|
||||
(assert-type section-name string)
|
||||
(depict-mode markup-stream depict-env nil)
|
||||
(depict-paragraph (markup-stream :subsection-heading)
|
||||
(depict markup-stream section-name)))
|
||||
|
||||
|
||||
; (grammar-argument <argument> <attribute> <attribute> ... <attribute>)
|
||||
(defun depict-grammar-argument (markup-stream world depict-env argument &rest attributes)
|
||||
(declare (ignore world))
|
||||
(depict-mode markup-stream depict-env :syntax)
|
||||
(depict-paragraph (markup-stream :grammar-argument)
|
||||
(depict-nonterminal-argument markup-stream argument)
|
||||
(depict markup-stream " " :member-10 " ")
|
||||
(depict-list markup-stream
|
||||
#'(lambda (markup-stream attribute)
|
||||
(depict-nonterminal-attribute markup-stream attribute))
|
||||
attributes
|
||||
:prefix "{"
|
||||
:suffix "}"
|
||||
:separator ", ")))
|
||||
|
||||
|
||||
; (%rule <general-nonterminal-source>)
|
||||
(defun depict-%rule (markup-stream world depict-env general-nonterminal-source)
|
||||
(declare (ignore world))
|
||||
(let* ((grammar-info (checked-depict-env-grammar-info depict-env))
|
||||
(grammar (grammar-info-grammar grammar-info))
|
||||
(general-nonterminal (grammar-parametrization-intern grammar general-nonterminal-source))
|
||||
(seen-nonterminals (depict-env-seen-nonterminals depict-env)))
|
||||
(when (grammar-info-charclass grammar-info general-nonterminal)
|
||||
(error "Shouldn't use %rule on a lexer charclass nonterminal ~S" general-nonterminal))
|
||||
(labels
|
||||
((seen-nonterminal? (nonterminal)
|
||||
(gethash nonterminal seen-nonterminals)))
|
||||
(unless (every #'seen-nonterminal? (general-grammar-symbol-instances grammar general-nonterminal))
|
||||
(depict-mode markup-stream depict-env :syntax)
|
||||
(dolist (general-rule (grammar-general-rules grammar general-nonterminal))
|
||||
(let ((rule-lhs-nonterminals (general-grammar-symbol-instances grammar (general-rule-lhs general-rule))))
|
||||
(unless (every #'seen-nonterminal? rule-lhs-nonterminals)
|
||||
(when (some #'seen-nonterminal? rule-lhs-nonterminals)
|
||||
(warn "General rule for ~S listed before specific ones; use %rule to disambiguate" general-nonterminal))
|
||||
(depict-general-rule markup-stream general-rule)
|
||||
(dolist (nonterminal rule-lhs-nonterminals)
|
||||
(setf (gethash nonterminal seen-nonterminals) t)))))))))
|
||||
;******** May still have a problem when a specific rule precedes a general one.
|
||||
|
||||
|
||||
; (%charclass <nonterminal>)
|
||||
(defun depict-%charclass (markup-stream world depict-env nonterminal)
|
||||
(let* ((grammar-info (checked-depict-env-grammar-info depict-env))
|
||||
(charclass (grammar-info-charclass grammar-info nonterminal)))
|
||||
(unless charclass
|
||||
(error "%charclass with a non-charclass ~S" nonterminal))
|
||||
(if (gethash nonterminal (depict-env-seen-nonterminals depict-env))
|
||||
(warn "Duplicate charclass ~S" nonterminal)
|
||||
(progn
|
||||
(depict-mode markup-stream depict-env :syntax)
|
||||
(depict-charclass markup-stream charclass)
|
||||
(dolist (action-cons (charclass-actions charclass))
|
||||
(depict-charclass-action world depict-env (cdr action-cons) nonterminal))
|
||||
(setf (gethash nonterminal (depict-env-seen-nonterminals depict-env)) t)))))
|
||||
|
||||
|
||||
; (%print-actions)
|
||||
(defun depict-%print-actions (markup-stream world depict-env)
|
||||
(declare (ignore world))
|
||||
(dolist (pending-action (nreverse (depict-env-pending-actions-reverse depict-env)))
|
||||
(funcall pending-action markup-stream depict-env))
|
||||
(setf (depict-env-pending-actions-reverse depict-env) nil))
|
||||
|
||||
|
||||
; (deftype <name> <type>)
|
||||
(defun depict-deftype (markup-stream world depict-env name type-expr)
|
||||
(depict-semantics (markup-stream depict-env)
|
||||
(depict-logical-block (markup-stream 2)
|
||||
(depict-semantic-keyword markup-stream 'type)
|
||||
(depict-space markup-stream)
|
||||
(depict-type-name markup-stream name)
|
||||
(depict-break markup-stream 1)
|
||||
(depict-logical-block (markup-stream 3)
|
||||
(depict markup-stream "= ")
|
||||
(depict-type-expr markup-stream world type-expr)))))
|
||||
|
||||
|
||||
; (define <name> <type> <value> <destructured>)
|
||||
; <destructured> is a flag that is true if this define was originally in the form
|
||||
; (define (<name> (<arg1> <type1>) ... (<argn> <typen>)) <result-type> <value>)
|
||||
; and converted into
|
||||
; (define <name> (-> (<type1> ... <typen>) <result-type>)
|
||||
; (lambda ((<arg1> <type1>) ... (<argn> <typen>)) <value>)
|
||||
; t)
|
||||
(defun depict-define (markup-stream world depict-env name type-expr value-expr destructured)
|
||||
(depict-semantics (markup-stream depict-env)
|
||||
(depict-logical-block (markup-stream 2)
|
||||
(depict-global-variable markup-stream name)
|
||||
(flet
|
||||
((depict-type-and-value (markup-stream type-expr annotated-value-expr)
|
||||
(depict-logical-block (markup-stream 0)
|
||||
(depict-break markup-stream 1)
|
||||
(depict markup-stream ": ")
|
||||
(depict-type-expr markup-stream world type-expr))
|
||||
(depict-break markup-stream 1)
|
||||
(depict-logical-block (markup-stream 3)
|
||||
(depict markup-stream "= ")
|
||||
(depict-annotated-value-expr markup-stream world annotated-value-expr *primitive-level-max*))))
|
||||
|
||||
(let ((annotated-value-expr (nth-value 2 (scan-value world *null-type-env* value-expr))))
|
||||
(if destructured
|
||||
(progn
|
||||
(assert-true (eq (first type-expr) '->))
|
||||
(assert-true (special-form-annotated-expr? 'lambda annotated-value-expr))
|
||||
(depict-lambda-bindings markup-stream world (third annotated-value-expr))
|
||||
(depict-type-and-value markup-stream (third type-expr) (fourth annotated-value-expr)))
|
||||
(depict-type-and-value markup-stream type-expr annotated-value-expr)))))))
|
||||
|
||||
|
||||
; (set-grammar <name>)
|
||||
(defun depict-set-grammar (markup-stream world depict-env name)
|
||||
(depict-clear-grammar markup-stream world depict-env)
|
||||
(let ((grammar-info (world-grammar-info world name)))
|
||||
(unless grammar-info
|
||||
(error "Unknown grammar ~A" name))
|
||||
(setf (depict-env-grammar-info depict-env) grammar-info)
|
||||
(setf (depict-env-seen-nonterminals depict-env) (make-hash-table :test #'eq))))
|
||||
|
||||
|
||||
; (clear-grammar)
|
||||
(defun depict-clear-grammar (markup-stream world depict-env)
|
||||
(depict-%print-actions markup-stream world depict-env)
|
||||
(depict-mode markup-stream depict-env nil)
|
||||
(let ((grammar-info (depict-env-grammar-info depict-env)))
|
||||
(when grammar-info
|
||||
(let ((seen-nonterminals (depict-env-seen-nonterminals depict-env))
|
||||
(missed-nonterminals nil))
|
||||
(dolist (nonterminal (grammar-nonterminals-list (grammar-info-grammar grammar-info)))
|
||||
(unless (or (gethash nonterminal seen-nonterminals)
|
||||
(eq nonterminal *start-nonterminal*))
|
||||
(push nonterminal missed-nonterminals)))
|
||||
(when missed-nonterminals
|
||||
(warn "Nonterminals not printed: ~S" missed-nonterminals)))
|
||||
(setf (depict-env-grammar-info depict-env) nil)
|
||||
(setf (depict-env-seen-nonterminals depict-env) nil))))
|
||||
|
||||
|
||||
(defmacro depict-delayed-action ((markup-stream depict-env) &body depictor)
|
||||
`(push #'(lambda (,markup-stream ,depict-env) ,@depictor)
|
||||
(depict-env-pending-actions-reverse ,depict-env)))
|
||||
|
||||
|
||||
(defun depict-declare-action-contents (markup-stream world action-name general-grammar-symbol type-expr)
|
||||
(depict-semantic-keyword markup-stream 'action)
|
||||
(depict-space markup-stream)
|
||||
(depict-action-name markup-stream action-name)
|
||||
(depict markup-stream :action-begin)
|
||||
(depict-general-grammar-symbol markup-stream general-grammar-symbol)
|
||||
(depict markup-stream :action-end)
|
||||
(depict-break markup-stream 1)
|
||||
(depict-logical-block (markup-stream 2)
|
||||
(depict markup-stream ": ")
|
||||
(depict-type-expr markup-stream world type-expr)))
|
||||
|
||||
|
||||
; (declare-action <action-name> <general-grammar-symbol> <type>)
|
||||
(defun depict-declare-action (markup-stream world depict-env action-name general-grammar-symbol-source type-expr)
|
||||
(declare (ignore markup-stream))
|
||||
(let* ((grammar-info (checked-depict-env-grammar-info depict-env))
|
||||
(general-grammar-symbol (grammar-parametrization-intern (grammar-info-grammar grammar-info) general-grammar-symbol-source)))
|
||||
(unless (grammar-info-charclass-or-partition grammar-info general-grammar-symbol)
|
||||
(depict-delayed-action (markup-stream depict-env)
|
||||
(depict-semantics (markup-stream depict-env)
|
||||
(depict-logical-block (markup-stream 4)
|
||||
(depict-declare-action-contents markup-stream world action-name general-grammar-symbol type-expr)))))))
|
||||
|
||||
|
||||
; Declare and define the lexer-action on the charclass given by nonterminal.
|
||||
(defun depict-charclass-action (world depict-env lexer-action nonterminal)
|
||||
(depict-delayed-action (markup-stream depict-env)
|
||||
(depict-semantics (markup-stream depict-env)
|
||||
(depict-logical-block (markup-stream 4)
|
||||
(depict-declare-action-contents markup-stream world (lexer-action-name lexer-action)
|
||||
nonterminal (lexer-action-type-expr lexer-action))
|
||||
(depict-break markup-stream 1)
|
||||
(depict-logical-block (markup-stream 3)
|
||||
(depict markup-stream "= ")
|
||||
(depict-lexer-action markup-stream lexer-action nonterminal))))))
|
||||
|
||||
|
||||
; (action <action-name> <production-name> <body>)
|
||||
; <destructured> is a flag that is true if this define was originally in the form
|
||||
; (action (<action-name> (<arg1> <type1>) ... (<argn> <typen>)) <production-name> <body>)
|
||||
; and converted into
|
||||
; (action <action-name> <production-name> (lambda ((<arg1> <type1>) ... (<argn> <typen>)) <body>) t)
|
||||
(defun depict-action (markup-stream world depict-env action-name production-name body-expr destructured)
|
||||
(declare (ignore markup-stream))
|
||||
(let* ((grammar-info (checked-depict-env-grammar-info depict-env))
|
||||
(grammar (grammar-info-grammar grammar-info))
|
||||
(general-production (grammar-general-production grammar production-name)))
|
||||
(unless (grammar-info-charclass grammar-info (general-production-lhs general-production))
|
||||
(depict-delayed-action (markup-stream depict-env)
|
||||
(depict-semantics (markup-stream depict-env :semantics-next)
|
||||
(depict-logical-block (markup-stream 2)
|
||||
(let* ((initial-env (general-production-action-env grammar general-production))
|
||||
(body-annotated-expr (nth-value 2 (scan-value world initial-env body-expr)))
|
||||
(action-grammar-symbols (annotated-expr-grammar-symbols body-annotated-expr)))
|
||||
(depict-action-name markup-stream action-name)
|
||||
(depict markup-stream :action-begin)
|
||||
(depict-general-production markup-stream general-production action-grammar-symbols)
|
||||
(depict markup-stream :action-end)
|
||||
(flet
|
||||
((depict-body (markup-stream body-annotated-expr)
|
||||
(depict-break markup-stream 1)
|
||||
(depict-logical-block (markup-stream 3)
|
||||
(depict markup-stream "= ")
|
||||
(depict-annotated-value-expr markup-stream world body-annotated-expr *primitive-level-stmt*))))
|
||||
|
||||
(if destructured
|
||||
(progn
|
||||
(assert-true (special-form-annotated-expr? 'lambda body-annotated-expr))
|
||||
(depict-logical-block (markup-stream 10)
|
||||
(depict-break markup-stream 0)
|
||||
(depict-lambda-bindings markup-stream world (third body-annotated-expr)))
|
||||
(depict-body markup-stream (fourth body-annotated-expr)))
|
||||
(depict-body markup-stream body-annotated-expr))))))))))
|
||||
|
||||
|
||||
; (terminal-action <action-name> <terminal> <lisp-function-name>)
|
||||
(defun depict-terminal-action (markup-stream world depict-env action-name terminal function-name)
|
||||
(declare (ignore markup-stream world depict-env action-name terminal function-name)))
|
||||
Разница между файлами не показана из-за своего большого размера
Загрузить разницу
|
|
@ -0,0 +1,483 @@
|
|||
;;; The contents of this file are subject to the Netscape Public License
|
||||
;;; Version 1.0 (the "NPL"); you may not use this file except in
|
||||
;;; compliance with the NPL. You may obtain a copy of the NPL at
|
||||
;;; http://www.mozilla.org/NPL/
|
||||
;;;
|
||||
;;; Software distributed under the NPL is distributed on an "AS IS" basis,
|
||||
;;; WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
|
||||
;;; for the specific language governing rights and limitations under the
|
||||
;;; NPL.
|
||||
;;;
|
||||
;;; The Initial Developer of this code under the NPL is Netscape
|
||||
;;; Communications Corporation. Portions created by Netscape are
|
||||
;;; Copyright (C) 1998 Netscape Communications Corporation. All Rights
|
||||
;;; Reserved.
|
||||
|
||||
;;;
|
||||
;;; LALR(1) and LR(1) parametrized grammar utilities
|
||||
;;;
|
||||
;;; Waldemar Horwat (waldemar@netscape.com)
|
||||
;;;
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; UTILITIES
|
||||
|
||||
(declaim (inline identifier?))
|
||||
(defun identifier? (form)
|
||||
(and form (symbolp form) (not (keywordp form))))
|
||||
|
||||
(deftype identifier () '(satisfies identifier?))
|
||||
|
||||
|
||||
; Make sure that form is one of the following:
|
||||
; A symbol
|
||||
; An integer
|
||||
; A float
|
||||
; A character
|
||||
; A string
|
||||
; A list of zero or more forms that also satisfy ensure-proper-form;
|
||||
; the list cannot be dotted.
|
||||
; Return the form.
|
||||
(defun ensure-proper-form (form)
|
||||
(labels
|
||||
((ensure-list-form (form)
|
||||
(or (null form)
|
||||
(and (consp form)
|
||||
(progn
|
||||
(ensure-proper-form (car form))
|
||||
(ensure-list-form (cdr form)))))))
|
||||
(unless
|
||||
(or (symbolp form)
|
||||
(integerp form)
|
||||
(floatp form)
|
||||
(characterp form)
|
||||
(stringp form)
|
||||
(ensure-list-form form))
|
||||
(error "Bad form: ~S" form))
|
||||
form))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; TERMINALS
|
||||
|
||||
; A terminal is any of the following:
|
||||
; A symbol that is neither nil nor a keyword
|
||||
; A string;
|
||||
; A character;
|
||||
; An integer.
|
||||
(defun terminal? (x)
|
||||
(and x
|
||||
(or (and (symbolp x) (not (keywordp x)))
|
||||
(stringp x)
|
||||
(characterp x)
|
||||
(integerp x))))
|
||||
|
||||
; The following terminals are reserved and may not be used in user input:
|
||||
; $$ Marker for end of token stream
|
||||
(defconstant *end-marker* '$$)
|
||||
(defconstant *end-marker-terminal-number* 0)
|
||||
|
||||
(deftype terminal () '(satisfies terminal?))
|
||||
(deftype user-terminal () `(and terminal (not (eql ,*end-marker*))))
|
||||
|
||||
|
||||
; Emit markup for a terminal. subscript is an optional integer.
|
||||
(defun depict-terminal (markup-stream terminal &optional subscript)
|
||||
(cond
|
||||
((characterp terminal)
|
||||
(depict-char-style (markup-stream ':character-literal)
|
||||
(depict-character markup-stream terminal)
|
||||
(when subscript
|
||||
(depict-char-style (markup-stream ':plain-subscript)
|
||||
(depict-integer markup-stream subscript)))))
|
||||
((and terminal (symbolp terminal))
|
||||
(let ((name (symbol-name terminal)))
|
||||
(if (and (> (length name) 0) (char= (char name 0) #\$))
|
||||
(depict-char-style (markup-stream ':terminal)
|
||||
(depict markup-stream (subseq (symbol-upper-mixed-case-name terminal) 1))
|
||||
(when subscript
|
||||
(depict-char-style (markup-stream ':plain-subscript)
|
||||
(depict-integer markup-stream subscript))))
|
||||
(progn
|
||||
(depict-char-style (markup-stream ':terminal-keyword)
|
||||
(depict markup-stream (string-downcase name)))
|
||||
(when subscript
|
||||
(depict-char-style (markup-stream ':terminal)
|
||||
(depict-char-style (markup-stream ':plain-subscript)
|
||||
(depict-integer markup-stream subscript))))))))
|
||||
(t (error "Don't know how to emit markup for terminal ~S" terminal))))
|
||||
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; NONTERMINAL PARAMETERS
|
||||
|
||||
(declaim (inline nonterminal-parameter?))
|
||||
(defun nonterminal-parameter? (x)
|
||||
(symbolp x))
|
||||
(deftype nonterminal-parameter () 'symbol)
|
||||
|
||||
|
||||
; Return true if this nonterminal parameter is a constant.
|
||||
(declaim (inline nonterminal-attribute?))
|
||||
(defun nonterminal-attribute? (parameter)
|
||||
(and (symbolp parameter) (not (keywordp parameter))))
|
||||
(deftype nonterminal-attribute () '(and symbol (not keyword)))
|
||||
|
||||
|
||||
(defun depict-nonterminal-attribute (markup-stream attribute)
|
||||
(depict-char-style (markup-stream ':nonterminal)
|
||||
(depict-char-style (markup-stream ':nonterminal-attribute)
|
||||
(depict markup-stream (symbol-lower-mixed-case-name attribute)))))
|
||||
|
||||
|
||||
; Return true if this nonterminal parameter is a variable.
|
||||
(declaim (inline nonterminal-argument?))
|
||||
(defun nonterminal-argument? (parameter)
|
||||
(keywordp parameter))
|
||||
(deftype nonterminal-argument () 'keyword)
|
||||
|
||||
|
||||
(defparameter *special-nonterminal-arguments*
|
||||
'(:alpha :beta :gamma :delta :epsilon :zeta :eta :theta :iota :kappa :lambda :mu :nu
|
||||
:xi :omicron :pi :rho :sigma :tau :upsilon :phi :chi :psi :omega))
|
||||
|
||||
(defun depict-nonterminal-argument-symbol (markup-stream argument)
|
||||
(depict-char-style (markup-stream ':nonterminal-argument)
|
||||
(depict markup-stream
|
||||
(if (member argument *special-nonterminal-arguments*)
|
||||
argument
|
||||
(symbol-upper-mixed-case-name argument)))))
|
||||
|
||||
(defun depict-nonterminal-argument (markup-stream argument)
|
||||
(depict-char-style (markup-stream ':nonterminal)
|
||||
(depict-nonterminal-argument-symbol markup-stream argument)))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; ATTRIBUTED NONTERMINALS
|
||||
|
||||
; An attributed-nonterminal is a specific instantiation of a generic-nonterminal.
|
||||
(defstruct (attributed-nonterminal (:constructor allocate-attributed-nonterminal (symbol attributes))
|
||||
(:copier nil)
|
||||
(:predicate attributed-nonterminal?))
|
||||
(symbol nil :type keyword :read-only t) ;The name of the attributed nonterminal
|
||||
(attributes nil :type list :read-only t)) ;Ordered list of nonterminal attributes
|
||||
|
||||
|
||||
; Make an attributed nonterminal with the given symbol and attributes. If there
|
||||
; are no attributes, return the symbol as a plain nonterminal.
|
||||
; Nonterminals are eq whenever they have identical symbols and attribute lists.
|
||||
(defun make-attributed-nonterminal (symbol attributes)
|
||||
(assert-type symbol keyword)
|
||||
(assert-type attributes (list nonterminal-attribute))
|
||||
(if attributes
|
||||
(let ((generic-nonterminals (get symbol 'generic-nonterminals)))
|
||||
(or (cdr (assoc attributes generic-nonterminals :test #'equal))
|
||||
(let ((attributed-nonterminal (allocate-attributed-nonterminal symbol attributes)))
|
||||
(setf (get symbol 'generic-nonterminals)
|
||||
(acons attributes attributed-nonterminal generic-nonterminals))
|
||||
attributed-nonterminal)))
|
||||
symbol))
|
||||
|
||||
|
||||
(defmethod print-object ((attributed-nonterminal attributed-nonterminal) stream)
|
||||
(print-unreadable-object (attributed-nonterminal stream)
|
||||
(format stream "a ~@_~W~{ ~:_~W~}"
|
||||
(attributed-nonterminal-symbol attributed-nonterminal)
|
||||
(attributed-nonterminal-attributes attributed-nonterminal))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; GENERIC NONTERMINALS
|
||||
|
||||
; A generic-nonterminal is a parametrized nonterminal that can expand into two or more
|
||||
; attributed-nonterminals.
|
||||
(defstruct (generic-nonterminal (:constructor allocate-generic-nonterminal (symbol parameters))
|
||||
(:copier nil)
|
||||
(:predicate generic-nonterminal?))
|
||||
(symbol nil :type keyword :read-only t) ;The name of the generic nonterminal
|
||||
(parameters nil :type list :read-only t)) ;Ordered list of nonterminal attributes or arguments
|
||||
|
||||
|
||||
; Make a generic nonterminal with the given symbol and parameters. If none of
|
||||
; the parameters is an argument, make an attributed nonterminal instead. If there
|
||||
; are no parameters, return the symbol as a plain nonterminal.
|
||||
; Nonterminals are eq whenever they have identical symbols and parameter lists.
|
||||
(defun make-generic-nonterminal (symbol parameters)
|
||||
(assert-type symbol keyword)
|
||||
(if parameters
|
||||
(let ((generic-nonterminals (get symbol 'generic-nonterminals)))
|
||||
(or (cdr (assoc parameters generic-nonterminals :test #'equal))
|
||||
(progn
|
||||
(assert-type parameters (list nonterminal-parameter))
|
||||
(let ((generic-nonterminal (if (every #'nonterminal-attribute? parameters)
|
||||
(allocate-attributed-nonterminal symbol parameters)
|
||||
(allocate-generic-nonterminal symbol parameters))))
|
||||
(setf (get symbol 'generic-nonterminals)
|
||||
(acons parameters generic-nonterminal generic-nonterminals))
|
||||
generic-nonterminal))))
|
||||
symbol))
|
||||
|
||||
|
||||
(defmethod print-object ((generic-nonterminal generic-nonterminal) stream)
|
||||
(print-unreadable-object (generic-nonterminal stream)
|
||||
(format stream "g ~@_~W~{ ~:_~W~}"
|
||||
(generic-nonterminal-symbol generic-nonterminal)
|
||||
(generic-nonterminal-parameters generic-nonterminal))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; NONTERMINALS
|
||||
|
||||
;;; A nonterminal is a keyword or an attributed-nonterminal.
|
||||
(declaim (inline nonterminal?))
|
||||
(defun nonterminal? (x)
|
||||
(or (keywordp x) (attributed-nonterminal? x)))
|
||||
|
||||
; The following nonterminals are reserved and may not be used in user input:
|
||||
; :% Nonterminal that expands to the start nonterminal
|
||||
|
||||
(defconstant *start-nonterminal* :%)
|
||||
|
||||
(deftype nonterminal () '(or keyword attributed-nonterminal))
|
||||
(deftype user-nonterminal () `(and nonterminal (not (eql ,*start-nonterminal*))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; GENERAL NONTERMINALS
|
||||
|
||||
;;; A general-nonterminal is a nonterminal or a generic-nonterminal.
|
||||
(declaim (inline general-nonterminal?))
|
||||
(defun general-nonterminal? (x)
|
||||
(or (nonterminal? x) (generic-nonterminal? x)))
|
||||
|
||||
(deftype general-nonterminal () '(or nonterminal generic-nonterminal))
|
||||
|
||||
|
||||
; Return the list of parameters in the general-nonterminal. The list is empty if the
|
||||
; general-nonterminal is a plain nonterminal.
|
||||
(defun general-nonterminal-parameters (general-nonterminal)
|
||||
(cond
|
||||
((attributed-nonterminal? general-nonterminal) (attributed-nonterminal-attributes general-nonterminal))
|
||||
((generic-nonterminal? general-nonterminal) (generic-nonterminal-parameters general-nonterminal))
|
||||
(t (progn
|
||||
(assert-true (keywordp general-nonterminal))
|
||||
nil))))
|
||||
|
||||
|
||||
; Emit markup for a general-nonterminal. subscript is an optional integer.
|
||||
(defun depict-general-nonterminal (markup-stream general-nonterminal &optional subscript)
|
||||
(depict-char-style (markup-stream ':nonterminal)
|
||||
(labels
|
||||
((depict-nonterminal-parameter (markup-stream parameter)
|
||||
(if (nonterminal-attribute? parameter)
|
||||
(depict-char-style (markup-stream ':nonterminal-attribute)
|
||||
(depict markup-stream (symbol-lower-mixed-case-name parameter)))
|
||||
(depict-nonterminal-argument-symbol markup-stream parameter)))
|
||||
|
||||
(depict-parametrized-nonterminal (symbol parameters)
|
||||
(depict markup-stream (symbol-upper-mixed-case-name symbol))
|
||||
(depict-char-style (markup-stream ':superscript)
|
||||
(depict-list markup-stream #'depict-nonterminal-parameter parameters
|
||||
:separator ","))))
|
||||
|
||||
(cond
|
||||
((keywordp general-nonterminal)
|
||||
(depict markup-stream (symbol-upper-mixed-case-name general-nonterminal)))
|
||||
((attributed-nonterminal? general-nonterminal)
|
||||
(depict-parametrized-nonterminal (attributed-nonterminal-symbol general-nonterminal)
|
||||
(attributed-nonterminal-attributes general-nonterminal)))
|
||||
((generic-nonterminal? general-nonterminal)
|
||||
(depict-parametrized-nonterminal (generic-nonterminal-symbol general-nonterminal)
|
||||
(generic-nonterminal-parameters general-nonterminal)))
|
||||
(t (error "Bad nonterminal ~S" general-nonterminal)))
|
||||
(when subscript
|
||||
(depict-char-style (markup-stream ':plain-subscript)
|
||||
(depict-integer markup-stream subscript))))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; GRAMMAR SYMBOLS
|
||||
|
||||
;;; A grammar-symbol is either a terminal or a nonterminal.
|
||||
(deftype grammar-symbol () '(or terminal nonterminal))
|
||||
(deftype user-grammar-symbol () '(or user-terminal user-nonterminal))
|
||||
|
||||
;;; A general-grammar-symbol is either a terminal or a general-nonterminal.
|
||||
(deftype general-grammar-symbol () '(or terminal general-nonterminal))
|
||||
|
||||
|
||||
; Return true if the two grammar symbols are the same symbol.
|
||||
(declaim (inline grammar-symbol-=))
|
||||
(defun grammar-symbol-= (grammar-symbol1 grammar-symbol2)
|
||||
(eql grammar-symbol1 grammar-symbol2))
|
||||
; A version of grammar-symbol-= suitable for being the test function for hash tables.
|
||||
(defconstant *grammar-symbol-=* #'eql)
|
||||
|
||||
|
||||
; Return the general-grammar-symbol's symbol. Return it unchanged if it is not
|
||||
; an attributed or generic nonterminal.
|
||||
(defun general-grammar-symbol-symbol (general-grammar-symbol)
|
||||
(cond
|
||||
((attributed-nonterminal? general-grammar-symbol) (attributed-nonterminal-symbol general-grammar-symbol))
|
||||
((generic-nonterminal? general-grammar-symbol) (generic-nonterminal-symbol general-grammar-symbol))
|
||||
(t (assert-type general-grammar-symbol (or keyword terminal)))))
|
||||
|
||||
|
||||
; Return the list of arguments in the general-grammar-symbol. The list is empty if the
|
||||
; general-grammar-symbol is not a generic nonterminal.
|
||||
(defun general-grammar-symbol-arguments (general-grammar-symbol)
|
||||
(and (generic-nonterminal? general-grammar-symbol)
|
||||
(remove-if (complement #'nonterminal-argument?) (generic-nonterminal-parameters general-grammar-symbol))))
|
||||
|
||||
|
||||
; Emit markup for a general-grammar-symbol. subscript is an optional integer.
|
||||
(defun depict-general-grammar-symbol (markup-stream general-grammar-symbol &optional subscript)
|
||||
(if (general-nonterminal? general-grammar-symbol)
|
||||
(depict-general-nonterminal markup-stream general-grammar-symbol subscript)
|
||||
(depict-terminal markup-stream general-grammar-symbol subscript)))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; GRAMMAR PARAMETRIZATIONS
|
||||
|
||||
; A grammar parametrization holds the rules for converting nonterminal arguments into nonterminal attributes.
|
||||
(defstruct (grammar-parametrization (:constructor allocate-grammar-parametrization (argument-attributes))
|
||||
(:predicate grammar-parametrization?))
|
||||
(argument-attributes nil :type hash-table :read-only t)) ;Hash table of nonterminal-argument -> list of nonterminal-attributes
|
||||
|
||||
|
||||
(defun make-grammar-parametrization ()
|
||||
(allocate-grammar-parametrization (make-hash-table :test #'eq)))
|
||||
|
||||
|
||||
; Declare that nonterminal arguments with the given name can hold any of the
|
||||
; given nonterminal attributes given. At least one attribute must be provided.
|
||||
(defun grammar-parametrization-declare-argument (grammar-parametrization argument attributes)
|
||||
(assert-type argument nonterminal-argument)
|
||||
(assert-type attributes (list nonterminal-attribute))
|
||||
(assert-true attributes)
|
||||
(when (gethash argument (grammar-parametrization-argument-attributes grammar-parametrization))
|
||||
(error "Duplicate parametrized grammar argument ~S" argument))
|
||||
(setf (gethash argument (grammar-parametrization-argument-attributes grammar-parametrization)) attributes))
|
||||
|
||||
|
||||
; Return the attributes to which the given argument may expand.
|
||||
(defun grammar-parametrization-lookup-argument (grammar-parametrization argument)
|
||||
(assert-non-null (gethash argument (grammar-parametrization-argument-attributes grammar-parametrization))))
|
||||
|
||||
|
||||
; Create a plain, attributed, or generic grammar symbol from the specification in grammar-symbol-source.
|
||||
; If grammar-symbol-source is not a cons, it is a plain grammar symbol. If it is a list, its first element
|
||||
; must be a keyword that is a nonterminal's symbol and the other elements must be nonterminal
|
||||
; parameters.
|
||||
; Return two values:
|
||||
; the grammar symbol
|
||||
; a list of arguments used in the grammar symbol.
|
||||
; If allowed-arguments is given, check that each argument is in the allowed-arguments list;
|
||||
; if not, allow any arguments declared in grammar-parametrization but do not allow duplicates.
|
||||
(defun grammar-parametrization-intern (grammar-parametrization grammar-symbol-source &optional (allowed-arguments nil allow-duplicates))
|
||||
(if (consp grammar-symbol-source)
|
||||
(progn
|
||||
(assert-type grammar-symbol-source (cons keyword (list nonterminal-parameter)))
|
||||
(let* ((symbol (car grammar-symbol-source))
|
||||
(parameters (cdr grammar-symbol-source))
|
||||
(arguments (remove-if (complement #'nonterminal-argument?) parameters)))
|
||||
(mapl #'(lambda (arguments)
|
||||
(let ((argument (car arguments)))
|
||||
(if allow-duplicates
|
||||
(unless (member argument allowed-arguments :test #'eq)
|
||||
(error "Undefined nonterminal argument ~S" argument))
|
||||
(progn
|
||||
(unless (gethash argument (grammar-parametrization-argument-attributes grammar-parametrization))
|
||||
(error "Undeclared nonterminal argument ~S" argument))
|
||||
(when (member argument (cdr arguments) :test #'eq)
|
||||
(error "Duplicate nonterminal argument ~S" argument))))))
|
||||
arguments)
|
||||
(values (make-generic-nonterminal symbol parameters) arguments)))
|
||||
(values grammar-symbol-source nil)))
|
||||
|
||||
|
||||
; Call f on each possible binding permutation of the given arguments concatenated with the bindings in
|
||||
; bound-argument-alist. f takes one argument, an association list that maps arguments to attributes.
|
||||
(defun grammar-parametrization-each-permutation (grammar-parametrization f arguments &optional bound-argument-alist)
|
||||
(if arguments
|
||||
(let ((argument (car arguments))
|
||||
(rest-arguments (cdr arguments)))
|
||||
(dolist (attribute (grammar-parametrization-lookup-argument grammar-parametrization argument))
|
||||
(grammar-parametrization-each-permutation grammar-parametrization f rest-arguments (acons argument attribute bound-argument-alist))))
|
||||
(funcall f bound-argument-alist)))
|
||||
|
||||
|
||||
; If general-grammar-symbol is a generic-nonterminal, return one possible binding permutation of its arguments;
|
||||
; otherwise return nil.
|
||||
(defun nonterminal-sample-bound-argument-alist (grammar-parametrization general-grammar-symbol)
|
||||
(when (generic-nonterminal? general-grammar-symbol)
|
||||
(grammar-parametrization-each-permutation
|
||||
grammar-parametrization
|
||||
#'(lambda (bound-argument-alist) (return-from nonterminal-sample-bound-argument-alist bound-argument-alist))
|
||||
(general-grammar-symbol-arguments general-grammar-symbol))))
|
||||
|
||||
|
||||
; If the grammar symbol is a generic nonterminal, convert it into an attributed nonterminal
|
||||
; by instantiating its arguments with the corresponding attributes from the bound-argument-alist.
|
||||
; If the grammar symbol is already an attributed or plain nonterminal, return it unchanged.
|
||||
(defun instantiate-general-grammar-symbol (bound-argument-alist general-grammar-symbol)
|
||||
(if (generic-nonterminal? general-grammar-symbol)
|
||||
(make-attributed-nonterminal
|
||||
(generic-nonterminal-symbol general-grammar-symbol)
|
||||
(mapcar #'(lambda (parameter)
|
||||
(if (nonterminal-argument? parameter)
|
||||
(let ((binding (assoc parameter bound-argument-alist :test #'eq)))
|
||||
(if binding
|
||||
(cdr binding)
|
||||
(error "Unbound nonterminal argument ~S" parameter)))
|
||||
parameter))
|
||||
(generic-nonterminal-parameters general-grammar-symbol)))
|
||||
(assert-type general-grammar-symbol grammar-symbol)))
|
||||
|
||||
|
||||
; If the grammar symbol is a generic nonterminal parametrized on argument, substitute
|
||||
; attribute for argument in it and return the modified grammar symbol. Otherwise, return it unchanged.
|
||||
(defun general-grammar-symbol-substitute (attribute argument general-grammar-symbol)
|
||||
(assert-type attribute nonterminal-attribute)
|
||||
(assert-type argument nonterminal-argument)
|
||||
(if (and (generic-nonterminal? general-grammar-symbol)
|
||||
(member argument (generic-nonterminal-parameters general-grammar-symbol) :test #'eq))
|
||||
(make-generic-nonterminal
|
||||
(generic-nonterminal-symbol general-grammar-symbol)
|
||||
(substitute attribute argument (generic-nonterminal-parameters general-grammar-symbol) :test #'eq))
|
||||
(assert-type general-grammar-symbol general-grammar-symbol)))
|
||||
|
||||
|
||||
; If the general grammar symbol is a generic nonterminal, return a list of all possible attributed nonterminals
|
||||
; that can be instantiated from it; otherwise, return a one-element list containing the given general grammar symbol.
|
||||
(defun general-grammar-symbol-instances (grammar-parametrization general-grammar-symbol)
|
||||
(if (generic-nonterminal? general-grammar-symbol)
|
||||
(let ((instances nil))
|
||||
(grammar-parametrization-each-permutation
|
||||
grammar-parametrization
|
||||
#'(lambda (bound-argument-alist)
|
||||
(push (instantiate-general-grammar-symbol bound-argument-alist general-grammar-symbol) instances))
|
||||
(general-grammar-symbol-arguments general-grammar-symbol))
|
||||
(nreverse instances))
|
||||
(list (assert-type general-grammar-symbol grammar-symbol))))
|
||||
|
||||
|
||||
; Return true if grammar-symbol can be obtained by calling instantiate-general-grammar-symbol on
|
||||
; general-grammar-symbol.
|
||||
(defun general-nonterminal-is-instance? (grammar-parametrization general-grammar-symbol grammar-symbol)
|
||||
(or (grammar-symbol-= general-grammar-symbol grammar-symbol)
|
||||
(and (generic-nonterminal? general-grammar-symbol)
|
||||
(attributed-nonterminal? grammar-symbol)
|
||||
(let ((parameters (generic-nonterminal-parameters general-grammar-symbol))
|
||||
(attributes (attributed-nonterminal-attributes grammar-symbol)))
|
||||
(and (= (length parameters) (length attributes))
|
||||
(every #'(lambda (parameter attribute)
|
||||
(or (eq parameter attribute)
|
||||
(and (nonterminal-argument? parameter)
|
||||
(member attribute (grammar-parametrization-lookup-argument grammar-parametrization parameter) :test #'eq))))
|
||||
parameters
|
||||
attributes))))))
|
||||
|
|
@ -0,0 +1,531 @@
|
|||
;;; The contents of this file are subject to the Netscape Public License
|
||||
;;; Version 1.0 (the "NPL"); you may not use this file except in
|
||||
;;; compliance with the NPL. You may obtain a copy of the NPL at
|
||||
;;; http://www.mozilla.org/NPL/
|
||||
;;;
|
||||
;;; Software distributed under the NPL is distributed on an "AS IS" basis,
|
||||
;;; WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
|
||||
;;; for the specific language governing rights and limitations under the
|
||||
;;; NPL.
|
||||
;;;
|
||||
;;; The Initial Developer of this code under the NPL is Netscape
|
||||
;;; Communications Corporation. Portions created by Netscape are
|
||||
;;; Copyright (C) 1999 Netscape Communications Corporation. All Rights
|
||||
;;; Reserved.
|
||||
|
||||
;;;
|
||||
;;; HTML output generator
|
||||
;;;
|
||||
;;; Waldemar Horwat (waldemar@netscape.com)
|
||||
;;;
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; ELEMENTS
|
||||
|
||||
(defstruct (html-element (:constructor make-html-element (name self-closing indent
|
||||
newlines-before newlines-begin newlines-end newlines-after))
|
||||
(:predicate html-element?))
|
||||
(name nil :type symbol :read-only t) ;Name of the tag
|
||||
(self-closing nil :type bool :read-only t) ;True if the closing tag should be omitted
|
||||
(indent nil :type integer :read-only t) ;Number of spaces by which to indent this tag's contents in HTML source
|
||||
(newlines-before nil :type integer :read-only t) ;Number of HTML source newlines preceding the opening tag
|
||||
(newlines-begin nil :type integer :read-only t) ;Number of HTML source newlines immediately following the opening tag
|
||||
(newlines-end nil :type integer :read-only t) ;Number of HTML source newlines immediately preceding the closing tag
|
||||
(newlines-after nil :type integer :read-only t)) ;Number of HTML source newlines following the closing tag
|
||||
|
||||
|
||||
; Define symbol to refer to the given html-element.
|
||||
(defun define-html (symbol newlines-before newlines-begin newlines-end newlines-after &key self-closing (indent 0))
|
||||
(setf (get symbol 'html-element) (make-html-element symbol self-closing indent
|
||||
newlines-before newlines-begin newlines-end newlines-after)))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; ELEMENT DEFINITIONS
|
||||
|
||||
(define-html 'a 0 0 0 0)
|
||||
(define-html 'b 0 0 0 0)
|
||||
(define-html 'blockquote 1 0 0 1 :indent 2)
|
||||
(define-html 'body 1 1 1 1)
|
||||
(define-html 'br 0 0 0 1 :self-closing t)
|
||||
(define-html 'code 0 0 0 0)
|
||||
(define-html 'dd 1 0 0 1 :indent 2)
|
||||
(define-html 'del 0 0 0 0)
|
||||
(define-html 'div 1 0 0 1 :indent 2)
|
||||
(define-html 'dl 1 0 0 2 :indent 2)
|
||||
(define-html 'dt 1 0 0 1 :indent 2)
|
||||
(define-html 'em 0 0 0 0)
|
||||
(define-html 'h1 1 0 0 2 :indent 2)
|
||||
(define-html 'h2 1 0 0 2 :indent 2)
|
||||
(define-html 'h3 1 0 0 2 :indent 2)
|
||||
(define-html 'h4 1 0 0 2 :indent 2)
|
||||
(define-html 'h5 1 0 0 2 :indent 2)
|
||||
(define-html 'h6 1 0 0 2 :indent 2)
|
||||
(define-html 'head 1 1 1 2)
|
||||
(define-html 'hr 1 0 0 1 :self-closing t)
|
||||
(define-html 'html 0 1 1 1)
|
||||
(define-html 'i 0 0 0 0)
|
||||
(define-html 'li 1 0 0 1 :indent 2)
|
||||
(define-html 'link 1 0 0 1 :self-closing t)
|
||||
(define-html 'ol 1 1 1 2 :indent 2)
|
||||
(define-html 'p 1 0 0 2)
|
||||
(define-html 'span 0 0 0 0)
|
||||
(define-html 'strong 0 0 0 0)
|
||||
(define-html 'sub 0 0 0 0)
|
||||
(define-html 'sup 0 0 0 0)
|
||||
(define-html 'table 1 1 1 2)
|
||||
(define-html 'td 1 0 0 1 :indent 2)
|
||||
(define-html 'th 1 0 0 1 :indent 2)
|
||||
(define-html 'title 1 0 0 1)
|
||||
(define-html 'tr 1 0 0 1 :indent 2)
|
||||
(define-html 'u 0 0 0 0)
|
||||
(define-html 'ul 1 1 1 2 :indent 2)
|
||||
(define-html 'var 0 0 0 0)
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; ENTITIES
|
||||
|
||||
(defvar *html-entities-list*
|
||||
'((#\& . "amp")
|
||||
(#\" . "quot")
|
||||
(#\< . "lt")
|
||||
(#\> . "gt")
|
||||
(nbsp . "nbsp")))
|
||||
|
||||
(defvar *html-entities-hash* (make-hash-table))
|
||||
|
||||
(dolist (entity-binding *html-entities-list*)
|
||||
(setf (gethash (first entity-binding) *html-entities-hash*) (rest entity-binding)))
|
||||
|
||||
|
||||
; Return a freshly consed list of <html-source> that represent the characters in the string except that
|
||||
; '&', '<', and '>' are replaced by their entities and spaces are replaced by the entity
|
||||
; given by the space parameter (which should be either 'space or 'nbsp).
|
||||
(defun escape-html-characters (string space)
|
||||
(let ((html-sources nil))
|
||||
(labels
|
||||
((escape-remainder (start)
|
||||
(let ((i (position-if #'(lambda (char) (member char '(#\& #\< #\> #\space))) string :start start)))
|
||||
(if i
|
||||
(let ((char (char string i)))
|
||||
(unless (= i start)
|
||||
(push (subseq string start i) html-sources))
|
||||
(push (if (eql char #\space) space char) html-sources)
|
||||
(escape-remainder (1+ i)))
|
||||
(push (if (zerop start) string (subseq string start)) html-sources)))))
|
||||
(unless (zerop (length string))
|
||||
(escape-remainder 0))
|
||||
(nreverse html-sources))))
|
||||
|
||||
|
||||
; Escape all content strings in the html-source, while interpreting :nowrap pseudo-tags.
|
||||
; Return a freshly consed list of html-sources.
|
||||
(defun escape-html-source (html-source space)
|
||||
(cond
|
||||
((stringp html-source)
|
||||
(escape-html-characters html-source space))
|
||||
((or (characterp html-source) (symbolp html-source) (integerp html-source))
|
||||
(list html-source))
|
||||
((consp html-source)
|
||||
(let ((tag (first html-source))
|
||||
(contents (rest html-source)))
|
||||
(if (eq tag ':nowrap)
|
||||
(mapcan #'(lambda (html-source) (escape-html-source html-source 'nbsp)) contents)
|
||||
(list (cons tag
|
||||
(mapcan #'(lambda (html-source) (escape-html-source html-source space)) contents))))))
|
||||
(t (error "Bad html-source: ~S" html-source))))
|
||||
|
||||
|
||||
; Escape all content strings in the html-source, while interpreting :nowrap pseudo-tags.
|
||||
(defun escape-html (html-source)
|
||||
(let ((results (escape-html-source html-source 'space)))
|
||||
(assert-true (= (length results) 1))
|
||||
(first results)))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; HTML WRITER
|
||||
|
||||
;; <html-source> has one of the following formats:
|
||||
;; <string> ;String to be printed literally
|
||||
;; <symbol> ;Named entity
|
||||
;; <integer> ;Numbered entity
|
||||
;; space ;Space or newline
|
||||
;; (<tag> <html-source> ... <html-source>) ;Tag and its contents
|
||||
;; ((:nest <tag> ... <tag>) <html-source> ... <html-source>) ;Equivalent to (<tag> (... (<tag> <html-source> ... <html-source>)))
|
||||
;;
|
||||
;; <tag> has one of the following formats:
|
||||
;; <symbol> ;Tag with no attributes
|
||||
;; (<symbol> <attribute> ... <attribute>) ;Tag with attributes
|
||||
;; :nowrap ;Pseudo-tag indicating that spaces in contents should be non-breaking
|
||||
;;
|
||||
;; <attribute> has one of the following formats:
|
||||
;; (<symbol> <string>) ;Attribute name and value
|
||||
;; (<symbol>) ;Attribute name with omitted value
|
||||
|
||||
|
||||
(defparameter *html-right-margin* 100)
|
||||
|
||||
(defvar *current-html-pos*) ;Number of characters written to the current line of the stream; nil if *current-html-newlines* is nonzero
|
||||
(defvar *current-html-pending*) ;String following a space or newline pending to be printed on the current line or nil if none
|
||||
(defvar *current-html-indent*) ;Indent to use for emit-html-newlines-and-indent calls
|
||||
(defvar *current-html-newlines*) ;Number of consecutive newlines just written to the stream; zero if last character wasn't a newline
|
||||
|
||||
|
||||
; Flush *current-html-pending* onto the stream.
|
||||
(defun flush-current-html-pending (stream)
|
||||
(when *current-html-pending*
|
||||
(unless (zerop (length *current-html-pending*))
|
||||
(write-char #\space stream)
|
||||
(write-string *current-html-pending* stream)
|
||||
(incf *current-html-pos* (1+ (length *current-html-pending*))))
|
||||
(setq *current-html-pending* nil)))
|
||||
|
||||
|
||||
; Emit n-newlines onto the stream and indent the next line by *current-html-indent* spaces.
|
||||
(defun emit-html-newlines-and-indent (stream n-newlines)
|
||||
(decf n-newlines *current-html-newlines*)
|
||||
(when (plusp n-newlines)
|
||||
(flush-current-html-pending stream)
|
||||
(dotimes (i n-newlines)
|
||||
(write-char #\newline stream))
|
||||
(incf *current-html-newlines* n-newlines)
|
||||
(setq *current-html-pos* nil)))
|
||||
|
||||
|
||||
; Write the string to the stream, observing *current-html-pending* and *current-html-pos*.
|
||||
(defun write-html-string (stream html-string)
|
||||
(unless (zerop (length html-string))
|
||||
(unless *current-html-pos*
|
||||
(setq *current-html-newlines* 0)
|
||||
(write-string (make-string *current-html-indent* :initial-element #\space) stream)
|
||||
(setq *current-html-pos* *current-html-indent*))
|
||||
(if *current-html-pending*
|
||||
(progn
|
||||
(setq *current-html-pending* (if (zerop (length *current-html-pending*))
|
||||
html-string
|
||||
(concatenate 'string *current-html-pending* html-string)))
|
||||
(when (>= (+ *current-html-pos* (length *current-html-pending*)) *html-right-margin*)
|
||||
(write-char #\newline stream)
|
||||
(write-string *current-html-pending* stream)
|
||||
(setq *current-html-pos* (length *current-html-pending*))
|
||||
(setq *current-html-pending* nil)))
|
||||
(progn
|
||||
(write-string html-string stream)
|
||||
(incf *current-html-pos* (length html-string))))))
|
||||
|
||||
|
||||
; Emit the html tag with the given tag-symbol (name), attributes, and contents.
|
||||
(defun write-html-tag (stream tag-symbol attributes contents)
|
||||
(let ((element (assert-non-null (get tag-symbol 'html-element))))
|
||||
(emit-html-newlines-and-indent stream (html-element-newlines-before element))
|
||||
(write-html-string stream (format nil "<~A" (html-element-name element)))
|
||||
(let ((*current-html-indent* (+ *current-html-indent* (html-element-indent element))))
|
||||
(dolist (attribute attributes)
|
||||
(let ((name (first attribute))
|
||||
(value (second attribute)))
|
||||
(write-html-source stream 'space)
|
||||
(write-html-string stream (string-downcase (symbol-name name)))
|
||||
(when value
|
||||
(write-html-string stream (format nil "=\"~A\"" value)))))
|
||||
(write-html-string stream ">")
|
||||
(emit-html-newlines-and-indent stream (html-element-newlines-begin element))
|
||||
(dolist (html-source contents)
|
||||
(write-html-source stream html-source)))
|
||||
(unless (html-element-self-closing element)
|
||||
(emit-html-newlines-and-indent stream (html-element-newlines-end element))
|
||||
(write-html-string stream (format nil "</~A>" (html-element-name element))))
|
||||
(emit-html-newlines-and-indent stream (html-element-newlines-after element))))
|
||||
|
||||
|
||||
; Write html-source to the character stream.
|
||||
(defun write-html-source (stream html-source)
|
||||
(cond
|
||||
((stringp html-source)
|
||||
(write-html-string stream html-source))
|
||||
((eq html-source 'space)
|
||||
(when (zerop *current-html-newlines*)
|
||||
(flush-current-html-pending stream)
|
||||
(setq *current-html-pending* "")))
|
||||
((or (characterp html-source) (symbolp html-source))
|
||||
(let ((entity-name (gethash html-source *html-entities-hash*)))
|
||||
(cond
|
||||
(entity-name
|
||||
(write-html-string stream (format nil "&~A;" entity-name)))
|
||||
((characterp html-source)
|
||||
(write-html-string stream (string html-source)))
|
||||
(t (error "Bad html-source ~S" html-source)))))
|
||||
((integerp html-source)
|
||||
(assert-true (and (>= html-source 0) (< html-source 65536)))
|
||||
(write-html-string stream (format nil "&#~D;" html-source)))
|
||||
((consp html-source)
|
||||
(let ((tag (first html-source))
|
||||
(contents (rest html-source)))
|
||||
(if (consp tag)
|
||||
(write-html-tag stream (first tag) (rest tag) contents)
|
||||
(write-html-tag stream tag nil contents))))
|
||||
(t (error "Bad html-source: ~S" html-source))))
|
||||
|
||||
|
||||
; Write the top-level html-source to the character stream.
|
||||
(defun write-html (html-source &optional (stream t))
|
||||
(with-standard-io-syntax
|
||||
(let ((*print-readably* nil)
|
||||
(*print-escape* nil)
|
||||
(*print-case* :upcase)
|
||||
(*current-html-pos* nil)
|
||||
(*current-html-pending* nil)
|
||||
(*current-html-indent* 0)
|
||||
(*current-html-newlines* 9999))
|
||||
(write-string "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0 Transitional//EN\" \"http://www.w3.org/TR/REC-html40/loose.dtd\">" stream)
|
||||
(write-char #\newline stream)
|
||||
(write-html-source stream (escape-html html-source)))))
|
||||
|
||||
|
||||
; Write html to the text file with the given name (relative to the
|
||||
; local directory).
|
||||
(defun write-html-to-local-file (filename html)
|
||||
(with-open-file (stream (merge-pathnames filename *semantic-engine-directory*)
|
||||
:direction :output
|
||||
:if-exists :supersede
|
||||
#+mcl :mac-file-creator #+mcl "MOSS")
|
||||
(write-html html stream)))
|
||||
|
||||
|
||||
; Expand the :nest constructs inside html-source.
|
||||
(defun unnest-html-source (html-source)
|
||||
(labels
|
||||
((unnest-tags (tags contents)
|
||||
(assert-true tags)
|
||||
(cons (first tags)
|
||||
(if (endp (rest tags))
|
||||
contents
|
||||
(list (unnest-tags (rest tags) contents))))))
|
||||
(if (consp html-source)
|
||||
(let ((tag (first html-source))
|
||||
(contents (rest html-source)))
|
||||
(if (and (consp tag) (eq (first tag) ':nest))
|
||||
(unnest-html-source (unnest-tags (rest tag) contents))
|
||||
(cons tag (mapcar #'unnest-html-source contents))))
|
||||
html-source)))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; HTML MAPPINGS
|
||||
|
||||
(defparameter *html-definitions*
|
||||
'(((:new-line t) (br))
|
||||
|
||||
;Misc.
|
||||
(:tab2 nbsp nbsp)
|
||||
(:tab3 nbsp nbsp nbsp)
|
||||
|
||||
;Symbols (-10 suffix means 10-point, etc.)
|
||||
((:bullet 1) #x2022)
|
||||
((:minus 1) "-")
|
||||
((:not-equal 1) #x2260)
|
||||
((:less-or-equal 1) #x2264)
|
||||
((:greater-or-equal 1) #x2265)
|
||||
((:infinity 1) #x221E)
|
||||
((:left-single-quote 1) #x2018)
|
||||
((:right-single-quote 1) #x2019)
|
||||
((:left-double-quote 1) #x201C)
|
||||
((:right-double-quote 1) #x201D)
|
||||
((:left-angle-quote 1) #x00AB)
|
||||
((:right-angle-quote 1) #x00BB)
|
||||
((:bottom-10 1) (:symbol #\x5E)) ;#x22A5
|
||||
((:up-arrow-10 1) (:symbol #\xAD)) ;#x2191
|
||||
((:function-arrow-10 2) (:symbol #\xAE)) ;#x2192
|
||||
((:cartesian-product-10 2) #x00D7)
|
||||
((:identical-10 2) (:symbol #\xBA)) ;#x2261
|
||||
((:member-10 2) (:symbol #\xCE)) ;#x2208
|
||||
((:derives-10 2) (:symbol #\xDE)) ;#x21D2
|
||||
((:left-triangle-bracket-10 1) (:symbol #\xE1)) ;#x2329
|
||||
((:right-triangle-bracket-10 1) (:symbol #\xF1)) ;#x232A
|
||||
((:big-plus-10 2) (:symbol #\xA8)) ;#x271A
|
||||
|
||||
((:alpha 1) (:symbol "a"))
|
||||
((:beta 1) (:symbol "b"))
|
||||
((:chi 1) (:symbol "c"))
|
||||
((:delta 1) (:symbol "d"))
|
||||
((:epsilon 1) (:symbol "e"))
|
||||
((:phi 1) (:symbol "f"))
|
||||
((:gamma 1) (:symbol "g"))
|
||||
((:eta 1) (:symbol "h"))
|
||||
((:iota 1) (:symbol "i"))
|
||||
((:kappa 1) (:symbol "k"))
|
||||
((:lambda 1) (:symbol "l"))
|
||||
((:mu 1) (:symbol "m"))
|
||||
((:nu 1) (:symbol "n"))
|
||||
((:omicron 1) (:symbol "o"))
|
||||
((:pi 1) (:symbol "p"))
|
||||
((:theta 1) (:symbol "q"))
|
||||
((:rho 1) (:symbol "r"))
|
||||
((:sigma 1) (:symbol "s"))
|
||||
((:tau 1) (:symbol "t"))
|
||||
((:upsilon 1) (:symbol "u"))
|
||||
((:omega 1) (:symbol "w"))
|
||||
((:xi 1) (:symbol "x"))
|
||||
((:psi 1) (:symbol "y"))
|
||||
((:zeta 1) (:symbol "z"))
|
||||
|
||||
;Block Styles
|
||||
(:body-text p)
|
||||
(:section-heading h2)
|
||||
(:subsection-heading h3)
|
||||
(:grammar-header h4)
|
||||
(:grammar-rule (:nest :nowrap (div (class "grammar-rule"))))
|
||||
(:grammar-lhs (:nest :nowrap (div (class "grammar-lhs"))))
|
||||
(:grammar-lhs-last :grammar-lhs)
|
||||
(:grammar-rhs (:nest :nowrap (div (class "grammar-rhs"))))
|
||||
(:grammar-rhs-last :grammar-rhs)
|
||||
(:grammar-argument (:nest :nowrap (div (class "grammar-argument"))))
|
||||
(:semantics (:nest :nowrap (p (class "semantics"))))
|
||||
(:semantics-next (:nest :nowrap (p (class "semantics-next"))))
|
||||
|
||||
;Inline Styles
|
||||
(:symbol (span (class "symbol")))
|
||||
(:character-literal code)
|
||||
(:character-literal-control (span (class "control")))
|
||||
(:terminal (span (class "terminal")))
|
||||
(:terminal-keyword (code (class "terminal-keyword")))
|
||||
(:nonterminal (var (class "nonterminal")))
|
||||
(:nonterminal-attribute (span (class "nonterminal-attribute")))
|
||||
(:nonterminal-argument (span (class "nonterminal-argument")))
|
||||
(:semantic-keyword (span (class "semantic-keyword")))
|
||||
(:type-expression (span (class "type-expression")))
|
||||
(:type-name (span (class "type-name")))
|
||||
(:field-name (span (class "field-name")))
|
||||
(:global-variable (span (class "global-variable")))
|
||||
(:local-variable (span (class "local-variable")))
|
||||
(:action-name (span (class "action-name")))
|
||||
|
||||
;Specials
|
||||
(:invisible del)
|
||||
((:but-not 6) (b "except"))
|
||||
(:subscript sub)
|
||||
(:superscript sup)
|
||||
(:plain-subscript :subscript)
|
||||
((:action-begin 1) "[")
|
||||
((:action-end 1) "]")
|
||||
((:vector-begin 1) (b "["))
|
||||
((:vector-end 1) (b "]"))
|
||||
((:empty-vector 2) (b "[]"))
|
||||
((:vector-append 2) :big-plus-10)
|
||||
((:tuple-begin 1) (b :left-triangle-bracket-10))
|
||||
((:tuple-end 1) (b :right-triangle-bracket-10))
|
||||
((:unit 4) (:global-variable "unit"))
|
||||
((:true 4) (:global-variable "true"))
|
||||
((:false 5) (:global-variable "false"))
|
||||
))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; HTML STREAMS
|
||||
|
||||
(defstruct (html-stream (:include markup-stream)
|
||||
(:constructor allocate-html-stream (env head tail level logical-position))
|
||||
(:copier nil)
|
||||
(:predicate html-stream?)))
|
||||
|
||||
|
||||
(defmethod print-object ((html-stream html-stream) stream)
|
||||
(print-unreadable-object (html-stream stream :identity t)
|
||||
(write-string "html-stream" stream)))
|
||||
|
||||
|
||||
; Make a new, empty, open html-stream with the given definitions for its markup-env.
|
||||
(defun make-html-stream (markup-env level &optional logical-position)
|
||||
(let ((head (list nil)))
|
||||
(allocate-html-stream markup-env head head level logical-position)))
|
||||
|
||||
|
||||
; Make a new, empty, open, top-level html-stream with the given definitions
|
||||
; for its markup-env.
|
||||
(defun make-top-level-html-stream (html-definitions)
|
||||
(let ((head (list nil))
|
||||
(markup-env (make-markup-env)))
|
||||
(markup-env-define-alist markup-env html-definitions)
|
||||
(allocate-html-stream markup-env head head *markup-stream-top-level* nil)))
|
||||
|
||||
|
||||
; Return the approximate width of the html item; return t if it is a line break.
|
||||
; Also allow html tags as long as they do not contain line breaks.
|
||||
(defmethod markup-group-width ((html-stream html-stream) item)
|
||||
(if (consp item)
|
||||
(reduce #'+ (rest item) :key #'(lambda (subitem) (markup-group-width html-stream subitem)))
|
||||
(markup-width html-stream item)))
|
||||
|
||||
|
||||
; Create a top-level html-stream and call emitter to emit its contents.
|
||||
; emitter takes one argument -- an html-stream to which it should emit paragraphs.
|
||||
; Return the top-level html-stream.
|
||||
(defun depict-html-top-level (emitter title)
|
||||
(let ((html-stream (make-top-level-html-stream *html-definitions*)))
|
||||
(markup-stream-append1 html-stream 'html)
|
||||
(depict-block-style (html-stream 'head)
|
||||
(depict-block-style (html-stream 'title)
|
||||
(markup-stream-append1 html-stream title))
|
||||
(markup-stream-append1 html-stream '((link (rel "stylesheet") (href "styles.css")))))
|
||||
(depict-block-style (html-stream 'body)
|
||||
(funcall emitter html-stream))
|
||||
html-stream))
|
||||
|
||||
|
||||
; Create a top-level html-stream and call emitter to emit its contents.
|
||||
; emitter takes one argument -- an html-stream to which it should emit paragraphs.
|
||||
; Write the resulting html to the text file with the given name (relative to the
|
||||
; local directory).
|
||||
(defun depict-html-to-local-file (filename emitter title)
|
||||
(let ((top-html-stream (depict-html-top-level emitter title)))
|
||||
(write-html-to-local-file filename (markup-stream-output top-html-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 ((html-stream html-stream))
|
||||
(unnest-html-source
|
||||
(markup-env-expand (markup-stream-env html-stream) (markup-stream-unexpanded-output html-stream) '(:nowrap :nest))))
|
||||
|
||||
|
||||
|
||||
(defmethod depict-block-style-f ((html-stream html-stream) block-style emitter)
|
||||
(assert-true (<= (markup-stream-level html-stream) *markup-stream-paragraph-level*))
|
||||
(assert-true (and block-style (symbolp block-style)))
|
||||
(let ((inner-html-stream (make-html-stream (markup-stream-env html-stream) *markup-stream-paragraph-level* nil)))
|
||||
(markup-stream-append1 inner-html-stream block-style)
|
||||
(prog1
|
||||
(funcall emitter inner-html-stream)
|
||||
(markup-stream-append1 html-stream (markup-stream-unexpanded-output inner-html-stream)))))
|
||||
|
||||
|
||||
(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 ((inner-html-stream (make-html-stream (markup-stream-env html-stream) *markup-stream-content-level* (make-logical-position))))
|
||||
(markup-stream-append1 inner-html-stream paragraph-style)
|
||||
(prog1
|
||||
(funcall emitter inner-html-stream)
|
||||
(markup-stream-append1 html-stream (markup-stream-unexpanded-output inner-html-stream)))))
|
||||
|
||||
|
||||
(defmethod depict-char-style-f ((html-stream html-stream) char-style emitter)
|
||||
(assert-true (>= (markup-stream-level html-stream) *markup-stream-content-level*))
|
||||
(assert-true (and char-style (symbolp char-style)))
|
||||
(let ((inner-html-stream (make-html-stream (markup-stream-env html-stream) *markup-stream-content-level* (markup-stream-logical-position html-stream))))
|
||||
(markup-stream-append1 inner-html-stream char-style)
|
||||
(prog1
|
||||
(funcall emitter inner-html-stream)
|
||||
(markup-stream-append1 html-stream (markup-stream-unexpanded-output inner-html-stream)))))
|
||||
|
||||
|
||||
#|
|
||||
(write-html
|
||||
'(html
|
||||
(head
|
||||
(:nowrap (title "This is my title!<>")))
|
||||
((body (atr1 "abc") (beta) (qq))
|
||||
"My page this is " (br) (p))))
|
||||
|#
|
||||
|
|
@ -0,0 +1,361 @@
|
|||
;;; The contents of this file are subject to the Netscape Public License
|
||||
;;; Version 1.0 (the "NPL"); you may not use this file except in
|
||||
;;; compliance with the NPL. You may obtain a copy of the NPL at
|
||||
;;; http://www.mozilla.org/NPL/
|
||||
;;;
|
||||
;;; Software distributed under the NPL is distributed on an "AS IS" basis,
|
||||
;;; WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
|
||||
;;; for the specific language governing rights and limitations under the
|
||||
;;; NPL.
|
||||
;;;
|
||||
;;; The Initial Developer of this code under the NPL is Netscape
|
||||
;;; Communications Corporation. Portions created by Netscape are
|
||||
;;; Copyright (C) 1999 Netscape Communications Corporation. All Rights
|
||||
;;; Reserved.
|
||||
|
||||
;;;
|
||||
;;; Sample JavaScript 1.x grammar
|
||||
;;;
|
||||
;;; Waldemar Horwat (waldemar@netscape.com)
|
||||
;;;
|
||||
|
||||
(declaim (optimize (debug 3)))
|
||||
|
||||
(progn
|
||||
(defparameter *jw*
|
||||
(generate-world
|
||||
"J"
|
||||
'((grammar code-grammar :lr-1 :program)
|
||||
|
||||
(%section "Expressions")
|
||||
|
||||
(%subsection "Primary Expressions")
|
||||
(production :primary-expression (this) primary-expression-this)
|
||||
(production :primary-expression (null) primary-expression-null)
|
||||
(production :primary-expression (true) primary-expression-true)
|
||||
(production :primary-expression (false) primary-expression-false)
|
||||
(production :primary-expression ($number) primary-expression-number)
|
||||
(production :primary-expression ($string) primary-expression-string)
|
||||
(production :primary-expression ($identifier) primary-expression-identifier)
|
||||
(production :primary-expression ($regular-expression) primary-expression-regular-expression)
|
||||
(production :primary-expression (\( :expression \)) primary-expression-parentheses)
|
||||
|
||||
|
||||
(%subsection "Left-Side Expressions")
|
||||
(grammar-argument :chi allow-calls no-calls)
|
||||
(grammar-argument :alpha allow-in no-in)
|
||||
|
||||
(production (:member-expression no-calls) (:primary-expression) member-expression-primary-expression)
|
||||
(production (:member-expression allow-calls) ((:member-expression no-calls) :arguments) call-expression-call-member-expression)
|
||||
(production (:member-expression allow-calls) ((:member-expression allow-calls) :arguments) call-expression-call-call-expression)
|
||||
(production (:member-expression :chi) ((:member-expression :chi) \[ :expression \]) member-expression-array)
|
||||
(production (:member-expression :chi) ((:member-expression :chi) \. $identifier) member-expression-property)
|
||||
(production (:member-expression no-calls) (new (:member-expression no-calls) :arguments) member-expression-new)
|
||||
|
||||
(production :new-expression ((:member-expression no-calls)) new-expression-member-expression)
|
||||
(production :new-expression (new :new-expression) new-expression-new)
|
||||
|
||||
(production :arguments (\( \)) arguments-empty)
|
||||
(production :arguments (\( :argument-list \)) arguments-list)
|
||||
|
||||
(production :argument-list ((:assignment-expression allow-in)) argument-list-one)
|
||||
(production :argument-list (:argument-list \, (:assignment-expression allow-in)) argument-list-more)
|
||||
|
||||
(production :left-side-expression (:new-expression) left-side-expression-new-expression)
|
||||
(production :left-side-expression ((:member-expression allow-calls)) left-side-expression-call-expression)
|
||||
|
||||
|
||||
(%subsection "Postfix Expressions")
|
||||
(production :postfix-expression (:left-side-expression) postfix-expression-left-side-expression)
|
||||
(production :postfix-expression (:left-side-expression ++) postfix-expression-increment)
|
||||
(production :postfix-expression (:left-side-expression --) postfix-expression-decrement)
|
||||
|
||||
|
||||
(%subsection "Unary Operators")
|
||||
(production :unary-expression (:postfix-expression) unary-expression-postfix)
|
||||
(production :unary-expression (delete :left-side-expression) unary-expression-delete)
|
||||
(production :unary-expression (void :unary-expression) unary-expression-void)
|
||||
(production :unary-expression (typeof :unary-expression) unary-expression-typeof)
|
||||
(production :unary-expression (++ :left-side-expression) unary-expression-increment)
|
||||
(production :unary-expression (-- :left-side-expression) unary-expression-decrement)
|
||||
(production :unary-expression (+ :unary-expression) unary-expression-plus)
|
||||
(production :unary-expression (- :unary-expression) unary-expression-minus)
|
||||
(production :unary-expression (~ :unary-expression) unary-expression-bitwise-not)
|
||||
(production :unary-expression (! :unary-expression) unary-expression-logical-not)
|
||||
|
||||
|
||||
(%subsection "Multiplicative Operators")
|
||||
(production :multiplicative-expression (:unary-expression) multiplicative-expression-unary)
|
||||
(production :multiplicative-expression (:multiplicative-expression * :unary-expression) multiplicative-expression-multiply)
|
||||
(production :multiplicative-expression (:multiplicative-expression / :unary-expression) multiplicative-expression-divide)
|
||||
(production :multiplicative-expression (:multiplicative-expression % :unary-expression) multiplicative-expression-remainder)
|
||||
|
||||
|
||||
(%subsection "Additive Operators")
|
||||
(production :additive-expression (:multiplicative-expression) additive-expression-multiplicative)
|
||||
(production :additive-expression (:additive-expression + :multiplicative-expression) additive-expression-add)
|
||||
(production :additive-expression (:additive-expression - :multiplicative-expression) additive-expression-subtract)
|
||||
|
||||
|
||||
(%subsection "Bitwise Shift Operators")
|
||||
(production :shift-expression (:additive-expression) shift-expression-additive)
|
||||
(production :shift-expression (:shift-expression << :additive-expression) shift-expression-left)
|
||||
(production :shift-expression (:shift-expression >> :additive-expression) shift-expression-right-signed)
|
||||
(production :shift-expression (:shift-expression >>> :additive-expression) shift-expression-right-unsigned)
|
||||
|
||||
|
||||
(%subsection "Relational Operators")
|
||||
(production (:relational-expression :alpha) (:shift-expression) relational-expression-shift)
|
||||
(production (:relational-expression :alpha) ((:relational-expression :alpha) < :shift-expression) relational-expression-less)
|
||||
(production (:relational-expression :alpha) ((:relational-expression :alpha) > :shift-expression) relational-expression-greater)
|
||||
(production (:relational-expression :alpha) ((:relational-expression :alpha) <= :shift-expression) relational-expression-less-or-equal)
|
||||
(production (:relational-expression :alpha) ((:relational-expression :alpha) >= :shift-expression) relational-expression-greater-or-equal)
|
||||
(production (:relational-expression :alpha) ((:relational-expression :alpha) instanceof :shift-expression) relational-expression-instanceof)
|
||||
(production (:relational-expression allow-in) ((:relational-expression allow-in) in :shift-expression) relational-expression-in)
|
||||
|
||||
|
||||
(%subsection "Equality Operators")
|
||||
(production (:equality-expression :alpha) ((:relational-expression :alpha)) equality-expression-relational)
|
||||
(production (:equality-expression :alpha) ((:equality-expression :alpha) == (:relational-expression :alpha)) equality-expression-equal)
|
||||
(production (:equality-expression :alpha) ((:equality-expression :alpha) != (:relational-expression :alpha)) equality-expression-not-equal)
|
||||
(production (:equality-expression :alpha) ((:equality-expression :alpha) === (:relational-expression :alpha)) equality-expression-strict-equal)
|
||||
(production (:equality-expression :alpha) ((:equality-expression :alpha) !== (:relational-expression :alpha)) equality-expression-strict-not-equal)
|
||||
|
||||
|
||||
(%subsection "Binary Bitwise Operators")
|
||||
(production (:bitwise-and-expression :alpha) ((:equality-expression :alpha)) bitwise-and-expression-equality)
|
||||
(production (:bitwise-and-expression :alpha) ((:bitwise-and-expression :alpha) & (:equality-expression :alpha)) bitwise-and-expression-and)
|
||||
|
||||
(production (:bitwise-xor-expression :alpha) ((:bitwise-and-expression :alpha)) bitwise-xor-expression-bitwise-and)
|
||||
(production (:bitwise-xor-expression :alpha) ((:bitwise-xor-expression :alpha) ^ (:bitwise-and-expression :alpha)) bitwise-xor-expression-xor)
|
||||
|
||||
(production (:bitwise-or-expression :alpha) ((:bitwise-xor-expression :alpha)) bitwise-or-expression-bitwise-xor)
|
||||
(production (:bitwise-or-expression :alpha) ((:bitwise-or-expression :alpha) \| (:bitwise-xor-expression :alpha)) bitwise-or-expression-or)
|
||||
|
||||
|
||||
(%subsection "Binary Logical Operators")
|
||||
(production (:logical-and-expression :alpha) ((:bitwise-or-expression :alpha)) logical-and-expression-bitwise-or)
|
||||
(production (:logical-and-expression :alpha) ((:logical-and-expression :alpha) && (:bitwise-or-expression :alpha)) logical-and-expression-and)
|
||||
|
||||
(production (:logical-or-expression :alpha) ((:logical-and-expression :alpha)) logical-or-expression-logical-and)
|
||||
(production (:logical-or-expression :alpha) ((:logical-or-expression :alpha) \|\| (:logical-and-expression :alpha)) logical-or-expression-or)
|
||||
|
||||
|
||||
(%subsection "Conditional Operator")
|
||||
(production (:conditional-expression :alpha) ((:logical-or-expression :alpha)) conditional-expression-logical-or)
|
||||
(production (:conditional-expression :alpha) ((:logical-or-expression :alpha) ? (:assignment-expression :alpha) \: (:assignment-expression :alpha)) conditional-expression-conditional)
|
||||
|
||||
|
||||
(%subsection "Assignment Operators")
|
||||
(production (:assignment-expression :alpha) ((:conditional-expression :alpha)) assignment-expression-conditional)
|
||||
(production (:assignment-expression :alpha) (:left-side-expression = (:assignment-expression :alpha)) assignment-expression-assignment)
|
||||
(production (:assignment-expression :alpha) (:left-side-expression :compound-assignment (:assignment-expression :alpha)) assignment-expression-compound)
|
||||
|
||||
(production :compound-assignment (*=) compound-assignment-multiply)
|
||||
(production :compound-assignment (/=) compound-assignment-divide)
|
||||
(production :compound-assignment (%=) compound-assignment-remainder)
|
||||
(production :compound-assignment (+=) compound-assignment-add)
|
||||
(production :compound-assignment (-=) compound-assignment-subtract)
|
||||
|
||||
|
||||
(%subsection "Expressions")
|
||||
(production (:comma-expression :alpha) ((:assignment-expression :alpha)) comma-expression-assignment)
|
||||
|
||||
(production :expression ((:comma-expression allow-in)) expression-comma-expression)
|
||||
|
||||
(production :optional-expression (:expression) optional-expression-expression)
|
||||
(production :optional-expression () optional-expression-empty)
|
||||
|
||||
|
||||
(%section "Statements")
|
||||
|
||||
(grammar-argument :omega
|
||||
abbrev ;optional semicolon
|
||||
abbrev-non-empty ;optional semicolon as long as statement isn't empty
|
||||
abbrev-no-short-if ;optional semicolon, but statement must not end with an if without an else
|
||||
full) ;semicolon required at the end
|
||||
|
||||
(production (:statement :omega) (:blocklike-statement) statement-blocklike-statement)
|
||||
(production (:statement :omega) (:unterminated-statement \;) statement-unterminated-statement)
|
||||
(production (:statement :omega) ((:nonuniform-statement :omega)) statement-nonuniform-statement)
|
||||
(production (:statement :omega) ((:if-statement :omega)) statement-if-statement)
|
||||
(production (:statement :omega) ((:while-statement :omega)) statement-while-statement)
|
||||
(production (:statement :omega) ((:for-statement :omega)) statement-for-statement)
|
||||
(production (:statement :omega) ((:labeled-statement :omega)) statement-labeled-statement)
|
||||
|
||||
;Statements that differ depending on omega
|
||||
(production (:nonuniform-statement :omega) (:empty-statement \;) nonuniform-statement-empty-statement)
|
||||
(production (:nonuniform-statement abbrev) (:empty-statement) nonuniform-statement-empty-statement-abbrev)
|
||||
(production (:nonuniform-statement abbrev) (:unterminated-statement) nonuniform-statement-unterminated-statement-abbrev)
|
||||
(production (:nonuniform-statement abbrev-non-empty) (:unterminated-statement) nonuniform-statement-unterminated-statement-abbrev-non-empty)
|
||||
(production (:nonuniform-statement abbrev-no-short-if) (:unterminated-statement) nonuniform-statement-unterminated-statement-abbrev-no-short-if)
|
||||
(production (:nonuniform-statement abbrev-no-short-if) (:empty-statement) nonuniform-statement-empty-statement-abbrev-no-short-if)
|
||||
|
||||
;Statements that always end with a '}'
|
||||
(production :blocklike-statement (:block) blocklike-statement-block)
|
||||
(production :blocklike-statement (:switch-statement) blocklike-statement-switch-statement)
|
||||
(production :blocklike-statement (:try-statement) blocklike-statement-try-statement)
|
||||
|
||||
;Statements that must be followed by a semicolon unless followed by a '}', 'else', or 'while' in a do-while
|
||||
(production :unterminated-statement (:variable-statement) unterminated-statement-variable-statement)
|
||||
(production :unterminated-statement (:expression-statement) unterminated-statement-expression-statement)
|
||||
(production :unterminated-statement (:do-statement) unterminated-statement-do-statement)
|
||||
(production :unterminated-statement (:continue-statement) unterminated-statement-continue-statement)
|
||||
(production :unterminated-statement (:break-statement) unterminated-statement-break-statement)
|
||||
(production :unterminated-statement (:return-statement) unterminated-statement-return-statement)
|
||||
(production :unterminated-statement (:throw-statement) unterminated-statement-throw-statement)
|
||||
|
||||
|
||||
(%subsection "Block")
|
||||
(production :block ({ :block-statements }) block-block-statements)
|
||||
|
||||
(production :block-statements ((:statement abbrev)) block-statements-one)
|
||||
(production :block-statements (:block-statements-prefix (:statement abbrev-non-empty)) block-statements-more)
|
||||
|
||||
(production :block-statements-prefix ((:statement full)) block-statements-prefix-one)
|
||||
(production :block-statements-prefix (:block-statements-prefix (:statement full)) block-statements-prefix-more)
|
||||
|
||||
|
||||
(%subsection "Variable Statement")
|
||||
(production :variable-statement (var (:variable-declaration-list allow-in)) variable-statement-declaration)
|
||||
|
||||
(production (:variable-declaration-list :alpha) ((:variable-declaration :alpha)) variable-declaration-list-one)
|
||||
(production (:variable-declaration-list :alpha) ((:variable-declaration-list :alpha) \, (:variable-declaration :alpha)) variable-declaration-list-more)
|
||||
|
||||
(production (:variable-declaration :alpha) ($identifier) variable-declaration-identifier)
|
||||
(production (:variable-declaration :alpha) ($identifier = (:assignment-expression :alpha)) variable-declaration-initializer)
|
||||
|
||||
|
||||
(%subsection "Empty Statement")
|
||||
(production :empty-statement () empty-statement-empty)
|
||||
|
||||
|
||||
(%subsection "Expression Statement")
|
||||
(production :expression-statement (:expression) expression-statement-expression)
|
||||
|
||||
|
||||
(%subsection "If Statement")
|
||||
(production (:if-statement abbrev) (if \( :expression \) (:statement abbrev)) if-statement-if-then-abbrev)
|
||||
(production (:if-statement abbrev-non-empty) (if \( :expression \) (:statement abbrev-non-empty)) if-statement-if-then-abbrev-non-empty)
|
||||
(production (:if-statement full) (if \( :expression \) (:statement full)) if-statement-if-then-full)
|
||||
(production (:if-statement :omega) (if \( :expression \) (:statement abbrev-no-short-if)
|
||||
else (:statement :omega)) if-statement-if-then-else)
|
||||
|
||||
|
||||
(%subsection "Do-While Statement")
|
||||
(production :do-statement (do (:statement abbrev-non-empty) while \( :expression \)) do-statement-do-while)
|
||||
|
||||
|
||||
(%subsection "While Statement")
|
||||
(production (:while-statement :omega) (while \( :expression \) (:statement :omega)) while-statement-while)
|
||||
|
||||
|
||||
(%subsection "For Statements")
|
||||
(production (:for-statement :omega) (for \( :for-initializer \; :optional-expression \; :optional-expression \)
|
||||
(:statement :omega)) for-statement-c-style)
|
||||
(production (:for-statement :omega) (for \( :for-in-binding in :expression \) (:statement :omega)) for-statement-in)
|
||||
|
||||
(production :for-initializer () for-initializer-empty)
|
||||
(production :for-initializer ((:comma-expression no-in)) for-initializer-expression)
|
||||
(production :for-initializer (var (:variable-declaration-list no-in)) for-initializer-variable-declaration)
|
||||
|
||||
(production :for-in-binding (:left-side-expression) for-in-binding-expression)
|
||||
(production :for-in-binding (var (:variable-declaration no-in)) for-in-binding-variable-declaration)
|
||||
|
||||
|
||||
(%subsection "Continue and Break Statements")
|
||||
(production :continue-statement (continue :optional-label) continue-statement-optional-label)
|
||||
|
||||
(production :break-statement (break :optional-label) break-statement-optional-label)
|
||||
|
||||
(production :optional-label () optional-label-default)
|
||||
(production :optional-label ($identifier) optional-label-identifier)
|
||||
|
||||
|
||||
(%subsection "Labeled Statements")
|
||||
(production (:labeled-statement :omega) ($identifier \: (:statement :omega)) labeled-statement-label)
|
||||
|
||||
|
||||
(%subsection "Return Statement")
|
||||
(production :return-statement (return :optional-expression) return-statement-optional-expression)
|
||||
|
||||
|
||||
(%subsection "Switch Statement")
|
||||
(production :switch-statement (switch \( :expression \) { }) switch-statement-empty)
|
||||
(production :switch-statement (switch \( :expression \) { :case-groups :last-case-group }) switch-statement-cases)
|
||||
|
||||
(production :case-groups () case-groups-empty)
|
||||
(production :case-groups (:case-groups :case-group) case-groups-more)
|
||||
|
||||
(production :case-group (:case-guards :block-statements-prefix) case-group-block-statements-prefix)
|
||||
|
||||
(production :last-case-group (:case-guards :block-statements) last-case-group-block-statements)
|
||||
|
||||
(production :case-guards (:case-guard) case-guards-one)
|
||||
(production :case-guards (:case-guards :case-guard) case-guards-more)
|
||||
|
||||
(production :case-guard (case :expression \:) case-guard-case)
|
||||
(production :case-guard (default \:) case-guard-default)
|
||||
|
||||
|
||||
(%subsection "Throw Statement")
|
||||
(production :throw-statement (throw :expression) throw-statement-throw)
|
||||
|
||||
|
||||
(%subsection "Try Statement")
|
||||
(production :try-statement (try :block :catch-clauses) try-statement-catch-clauses)
|
||||
(production :try-statement (try :block :finally-clause) try-statement-finally-clause)
|
||||
(production :try-statement (try :block :catch-clauses :finally-clause) try-statement-catch-clauses-finally-clause)
|
||||
|
||||
(production :catch-clauses (:catch-clause) catch-clauses-one)
|
||||
(production :catch-clauses (:catch-clauses :catch-clause) catch-clauses-more)
|
||||
|
||||
(production :catch-clause (catch \( $identifier \) :block) catch-clause-block)
|
||||
|
||||
(production :finally-clause (finally :block) finally-clause-block)
|
||||
|
||||
|
||||
(%section "Functions")
|
||||
|
||||
(production :function-declaration (function $identifier \( :formal-parameters \) { :function-statements }) function-declaration-statements)
|
||||
|
||||
(production :formal-parameters () formal-parameters-none)
|
||||
(production :formal-parameters (:formal-parameters-prefix) formal-parameters-some)
|
||||
|
||||
(production :formal-parameters-prefix ($identifier) formal-parameters-prefix-one)
|
||||
(production :formal-parameters-prefix (:formal-parameters-prefix \, $identifier) formal-parameters-prefix-more)
|
||||
|
||||
(production :function-statements ((:function-statement abbrev)) function-statements-one)
|
||||
(production :function-statements (:function-statements-prefix (:function-statement abbrev-non-empty)) function-statements-more)
|
||||
|
||||
(production :function-statements-prefix ((:function-statement full)) function-statements-prefix-one)
|
||||
(production :function-statements-prefix (:function-statements-prefix (:function-statement full)) function-statements-prefix-more)
|
||||
|
||||
(production (:function-statement :omega) ((:statement :omega)) function-statement-statement)
|
||||
(production (:function-statement :omega) (:function-declaration) function-statement-function-declaration)
|
||||
|
||||
|
||||
(%section "Programs")
|
||||
|
||||
(production :program (:function-statements) program)
|
||||
)))
|
||||
|
||||
(defparameter *jg* (world-grammar *jw* 'code-grammar)))
|
||||
|
||||
|
||||
#|
|
||||
(let ((*visible-modes* nil))
|
||||
(depict-rtf-to-local-file
|
||||
"JS14.rtf"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *jw*))))
|
||||
|
||||
(let ((*visible-modes* nil))
|
||||
(depict-html-to-local-file
|
||||
"JS14.html"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *jw*))
|
||||
"JavaScript 2.0 Grammar"))
|
||||
|
||||
(with-local-output (s "JS14.txt") (print-grammar *jg* s))
|
||||
|#
|
||||
|
|
@ -0,0 +1,624 @@
|
|||
;;; The contents of this file are subject to the Netscape Public License
|
||||
;;; Version 1.0 (the "NPL"); you may not use this file except in
|
||||
;;; compliance with the NPL. You may obtain a copy of the NPL at
|
||||
;;; http://www.mozilla.org/NPL/
|
||||
;;;
|
||||
;;; Software distributed under the NPL is distributed on an "AS IS" basis,
|
||||
;;; WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
|
||||
;;; for the specific language governing rights and limitations under the
|
||||
;;; NPL.
|
||||
;;;
|
||||
;;; The Initial Developer of this code under the NPL is Netscape
|
||||
;;; Communications Corporation. Portions created by Netscape are
|
||||
;;; Copyright (C) 1998 Netscape Communications Corporation. All Rights
|
||||
;;; Reserved.
|
||||
|
||||
;;;
|
||||
;;; Lexer grammar generator
|
||||
;;;
|
||||
;;; Waldemar Horwat (waldemar@netscape.com)
|
||||
;;;
|
||||
|
||||
|
||||
;;; A lexer grammar is an extension of a standard grammar that combines both parsing and combining
|
||||
;;; characters into character classes.
|
||||
;;;
|
||||
;;; A lexer grammar is comprised of the following:
|
||||
;;; a start nonterminal;
|
||||
;;; a list of grammar productions, in which each terminal must be a character;
|
||||
;;; a list of character classes, where each class is a list of:
|
||||
;;; a nonterminal C;
|
||||
;;; an expression <set-expr> that denotes the set of characters in character class C;
|
||||
;;; a list of bindings, each containing:
|
||||
;;; an action name;
|
||||
;;; a lexer-action name;
|
||||
;;; a list of lexer-action bindings, each containing:
|
||||
;;; a lexer-action name;
|
||||
;;; the type of this lexer-action's value;
|
||||
;;; the name of a lisp function (char -> value) that performs the lexer-action on a character.
|
||||
;;;
|
||||
;;; Grammar productions may refer to character classes C as nonterminals.
|
||||
;;;
|
||||
;;; An expression <set-expr> can be any of the following:
|
||||
;;; C The name of a previously defined character class.
|
||||
;;; every The set of all characters
|
||||
;;; (char1 char2 ... charn) The set of characters {char1, char2, ..., charn}
|
||||
;;; (+ <set-expr1> ... <set-exprn>) The set union of <set-expr1>, ..., <set-exprn>,
|
||||
;;; which should be disjoint.
|
||||
;;; (++ <set-expr1> ... <set-exprn>) Same as +, but printed on separate lines.
|
||||
;;; (- <set-expr1> <set-expr2>) The set of characters in <set-expr1> but not <set-expr2>;
|
||||
;;; <set-expr2> should be a subset of <set-expr1>.
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; SETS OF CHARACTERS
|
||||
|
||||
;;; A character set is represented by an integer.
|
||||
;;; The set may be infinite as long as its complement is finite.
|
||||
;;; Bit n is set if the character with code n is a member of the set.
|
||||
;;; The integer is negative if the set is infinite.
|
||||
|
||||
|
||||
; Print the charset
|
||||
(defun print-charset (charset &optional (stream t))
|
||||
(pprint-logical-block (stream (bitmap-to-ranges charset) :prefix "{" :suffix "}")
|
||||
(pprint-exit-if-list-exhausted)
|
||||
(loop
|
||||
(flet
|
||||
((int-to-char (i)
|
||||
(if (or (eq i :infinity) (= i char-code-limit))
|
||||
:infinity
|
||||
(code-char i))))
|
||||
(let* ((range (pprint-pop))
|
||||
(lo (int-to-char (car range)))
|
||||
(hi (int-to-char (cdr range))))
|
||||
(write (if (eql lo hi) lo (list lo hi)) :stream stream :pretty t)
|
||||
(pprint-exit-if-list-exhausted)
|
||||
(format stream " ~:_"))))))
|
||||
|
||||
|
||||
; Return the character set consisting of the single character char.
|
||||
(declaim (inline char-charset))
|
||||
(defun char-charset (char)
|
||||
(ash 1 (char-code char)))
|
||||
|
||||
|
||||
; Return the character set consisting of adding char to the given charset.
|
||||
(defun charset-add-char (charset char)
|
||||
(let ((i (char-code char)))
|
||||
(if (logbitp i charset)
|
||||
charset
|
||||
(logior charset (ash 1 i)))))
|
||||
|
||||
|
||||
; Return the union of the two character sets, which should be disjoint.
|
||||
(defun charset-union (charset1 charset2)
|
||||
(unless (zerop (logand charset1 charset2))
|
||||
(error "Union of overlapping character sets"))
|
||||
(logior charset1 charset2))
|
||||
|
||||
|
||||
; Return the difference of the two character sets, the second of which should be
|
||||
; a subset of the first.
|
||||
(defun charset-difference (charset1 charset2)
|
||||
(unless (zerop (logandc1 charset1 charset2))
|
||||
(error "Difference of non-subset character sets"))
|
||||
(logandc2 charset1 charset2))
|
||||
|
||||
|
||||
; Return true if the character set is empty.
|
||||
(declaim (inline charset-empty?))
|
||||
(defun charset-empty? (charset)
|
||||
(zerop charset))
|
||||
|
||||
|
||||
; Return true if the character set is infinite.
|
||||
(declaim (inline charset-infinite?))
|
||||
(defun charset-infinite? (charset)
|
||||
(minusp charset))
|
||||
|
||||
|
||||
; If the character set contains exactly one character, return that character;
|
||||
; otherwise, return nil.
|
||||
(defun charset-char (charset)
|
||||
(let ((hi (1- (integer-length charset))))
|
||||
(and (plusp charset) (= charset (ash 1 hi)) (code-char hi))))
|
||||
|
||||
|
||||
; Return the highest character in the character set, which must be finite and nonempty.
|
||||
(declaim (inline charset-highest-char))
|
||||
(defun charset-highest-char (charset)
|
||||
(assert-true (plusp charset))
|
||||
(code-char (1- (integer-length charset))))
|
||||
|
||||
|
||||
; Given a list of charsets, return a list of the largest possible
|
||||
; charsets (called partitions) such that:
|
||||
; for any input charset C and partition P, either P is entirely contained in C or it is disjoint from C;
|
||||
; all partitions are mutually disjoint;
|
||||
; the union of all partitions is the infinite set of all characters.
|
||||
(defun compute-partitions (charsets)
|
||||
(labels
|
||||
((split-partitions (partitions charset)
|
||||
(mapcan #'(lambda (partition)
|
||||
(remove-if #'zerop (list (logand partition charset) (logandc2 partition charset))))
|
||||
partitions))
|
||||
(partition< (partition1 partition2)
|
||||
(cond
|
||||
((minusp partition1) nil)
|
||||
((minusp partition2) t)
|
||||
(t (< partition1 partition2)))))
|
||||
(sort (reduce #'split-partitions charsets :initial-value '(-1))
|
||||
#'partition<)))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; LEXER-ACTIONS
|
||||
|
||||
(defstruct (lexer-action (:constructor make-lexer-action (name number type-expr function-name markup))
|
||||
(:copier nil)
|
||||
(:predicate lexer-action?))
|
||||
(name nil :type identifier :read-only t) ;The action name to use for this lexer-action
|
||||
(number nil :type integer :read-only t) ;Serial number of this lexer-action
|
||||
(type-expr nil :read-only t) ;A type expression that specifies the result type of list function function-name
|
||||
(function-name nil :type identifier :read-only t) ;A lisp function (char -> value) that performs the lexer-action on a character
|
||||
(markup nil :type list :read-only t)) ;Markup template describing this lexer-action; replace '* with the nonterminal
|
||||
|
||||
|
||||
(defun print-lexer-action (lexer-action &optional (stream t))
|
||||
(format stream "~@<~A ~@_~:I: ~<<<~;~W~;>>~:> ~_= ~<<~;#'~W~;>~:>~:>"
|
||||
(lexer-action-name lexer-action)
|
||||
(list (lexer-action-type-expr lexer-action))
|
||||
(list (lexer-action-function-name lexer-action))))
|
||||
|
||||
|
||||
(defun depict-lexer-action (markup-stream lexer-action nonterminal)
|
||||
(dolist (markup-item (lexer-action-markup lexer-action))
|
||||
(if (eq markup-item '*)
|
||||
(depict-general-nonterminal markup-stream nonterminal)
|
||||
(depict-group markup-stream markup-item))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; CHARCLASSES
|
||||
|
||||
(defstruct (charclass (:constructor make-charclass (nonterminal charset-source charset actions))
|
||||
(:predicate charclass?))
|
||||
(nonterminal nil :type nonterminal :read-only t) ;The nonterminal on the left-hand side of this production
|
||||
(charset-source nil :read-only t) ;The source expression for the charset
|
||||
(charset nil :type integer :read-only t) ;The set of characters in this class
|
||||
(actions nil :type list :read-only t)) ;List of (action-name . lexer-action)
|
||||
|
||||
|
||||
; Evaluate a <set-expr> whose syntax is given at the top of this file.
|
||||
; Return the charset.
|
||||
; charclasses-hash is a hash table of nonterminal -> charclass.
|
||||
(defun eval-charset-expr (charclasses-hash expr)
|
||||
(cond
|
||||
((null expr) 0)
|
||||
((eq expr 'every) -1)
|
||||
((symbolp expr)
|
||||
(charclass-charset
|
||||
(or (gethash expr charclasses-hash)
|
||||
(error "Character class ~S not defined" expr))))
|
||||
((consp expr)
|
||||
(labels
|
||||
((recursive-eval (expr)
|
||||
(eval-charset-expr charclasses-hash expr)))
|
||||
(case (car expr)
|
||||
((+ ++) (reduce #'charset-union (cdr expr) :initial-value 0 :key #'recursive-eval))
|
||||
(- (unless (cdr expr)
|
||||
(error "Bad character set expression ~S" expr))
|
||||
(reduce #'charset-difference (cdr expr) :key #'recursive-eval))
|
||||
(t (reduce #'charset-union expr :key #'char-charset)))))
|
||||
(t (error "Bad character set expression ~S" expr))))
|
||||
|
||||
|
||||
(defun print-charclass (charclass &optional (stream t))
|
||||
(pprint-logical-block (stream nil)
|
||||
(format stream "~W -> ~@_~:I" (charclass-nonterminal charclass))
|
||||
(print-charset (charclass-charset charclass) stream)
|
||||
(format stream " ~_")
|
||||
(pprint-fill stream (mapcar #'car (charclass-actions charclass)))))
|
||||
|
||||
|
||||
; Emit markup for the lexer charset expression.
|
||||
(defun depict-charset-source (markup-stream expr)
|
||||
(cond
|
||||
((null expr) (error "Can't emit null charset expression"))
|
||||
((eq expr 'every) (depict-general-nonterminal markup-stream ':any-character))
|
||||
((symbolp expr) (depict-general-nonterminal markup-stream expr))
|
||||
((consp expr)
|
||||
(case (car expr)
|
||||
((+ ++) (depict-list markup-stream #'depict-charset-source (cdr expr) :separator " | "))
|
||||
(- (depict-charset-source markup-stream (second expr))
|
||||
(depict markup-stream " " :but-not " ")
|
||||
(depict-list markup-stream #'depict-charset-source (cddr expr) :separator " | "))
|
||||
(t (depict-list markup-stream #'depict-terminal expr :separator " | "))))
|
||||
(t (error "Bad character set expression ~S" expr))))
|
||||
|
||||
|
||||
; Emit markup paragraphs for the lexer charclass.
|
||||
(defun depict-charclass (markup-stream charclass)
|
||||
(let ((nonterminal (charclass-nonterminal charclass))
|
||||
(expr (charclass-charset-source charclass)))
|
||||
(if (and (consp expr) (eq (car expr) '++))
|
||||
(let* ((subexprs (cdr expr))
|
||||
(length (length subexprs)))
|
||||
(depict-paragraph (markup-stream ':grammar-lhs)
|
||||
(depict-general-nonterminal markup-stream nonterminal)
|
||||
(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))
|
||||
(depict markup-stream " " ':derives-10 " ")
|
||||
(depict-charset-source markup-stream expr)))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; PARTITIONS
|
||||
|
||||
(defstruct (partition (:constructor make-partition (charset lexer-actions))
|
||||
(:predicate partition?))
|
||||
(charset nil :type integer :read-only t) ;The set of characters in this partition
|
||||
(lexer-actions nil :type list :read-only t)) ;List of lexer-actions needed on characters in this partition
|
||||
|
||||
(defconstant *default-partition-name* '$_other_) ;partition-name to use for characters not found in lexer-char-tokens
|
||||
|
||||
|
||||
(defun print-partition (partition-name partition &optional (stream t))
|
||||
(pprint-logical-block (stream nil)
|
||||
(format stream "~W -> ~@_~:I" partition-name)
|
||||
(print-charset (partition-charset partition) stream)
|
||||
(format stream " ~_")
|
||||
(pprint-fill stream (mapcar #'lexer-action-name (partition-lexer-actions partition)))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; LEXER
|
||||
|
||||
|
||||
(defstruct (lexer (:constructor allocate-lexer)
|
||||
(:copier nil)
|
||||
(:predicate lexer?))
|
||||
(lexer-actions nil :type hash-table :read-only t) ;Hash table of lexer-action-name -> lexer-action
|
||||
(charclasses nil :type list :read-only t) ;List of charclasses in the order in which they were given
|
||||
(charclasses-hash nil :type hash-table :read-only t) ;Hash table of nonterminal -> charclass
|
||||
(char-tokens nil :type hash-table :read-only t) ;Hash table of character -> (character or partition-name)
|
||||
(partition-names nil :type list :read-only t) ;List of partition names in the order in which they were created
|
||||
(partitions nil :type hash-table :read-only t) ;Hash table of partition-name -> partition
|
||||
(grammar nil :type (or null grammar)) ;Grammar that accepts exactly one lexer token
|
||||
(metagrammar nil :type (or null metagrammar))) ;Grammar that accepts the longest input sequence that forms a token
|
||||
|
||||
|
||||
; Return a function (character -> terminal) that classifies an input character
|
||||
; as either itself or a partition-name.
|
||||
; If the returned function is called on a non-character, it returns its input unchanged.
|
||||
(defun lexer-classifier (lexer)
|
||||
(let ((char-tokens (lexer-char-tokens lexer)))
|
||||
#'(lambda (char)
|
||||
(if (characterp char)
|
||||
(gethash char char-tokens *default-partition-name*)
|
||||
char))))
|
||||
|
||||
|
||||
; Return the charclass that defines the given lexer nonterminal or nil if none.
|
||||
(defun lexer-charclass (lexer nonterminal)
|
||||
(gethash nonterminal (lexer-charclasses-hash lexer)))
|
||||
|
||||
|
||||
; Return the charset of all characters that appear as terminals in grammar-source.
|
||||
(defun grammar-singletons (grammar-source)
|
||||
(assert-type grammar-source (list (tuple t (list t) identifier)))
|
||||
(let ((singletons 0))
|
||||
(dolist (production-source grammar-source)
|
||||
(dolist (grammar-symbol (second production-source))
|
||||
(when (characterp grammar-symbol)
|
||||
(setq singletons (charset-add-char singletons grammar-symbol)))))
|
||||
singletons))
|
||||
|
||||
|
||||
; Return the list of all lexer-action-names that appear in at least one charclass of which this
|
||||
; partition is a subset.
|
||||
(defun collect-lexer-action-names (charclasses partition)
|
||||
(let ((lexer-action-names nil))
|
||||
(dolist (charclass charclasses)
|
||||
(unless (zerop (logand (charclass-charset charclass) partition))
|
||||
(dolist (action (charclass-actions charclass))
|
||||
(pushnew (cdr action) lexer-action-names))))
|
||||
(sort lexer-action-names #'< :key #'lexer-action-number)))
|
||||
|
||||
|
||||
; Make a lexer structure corresponding to a grammar with the given source.
|
||||
; charclasses-source is a list of character classes, where each class is a list of:
|
||||
; a nonterminal C;
|
||||
; an expression <set-expr> that denotes the set of characters in character class C;
|
||||
; a list of bindings, each containing:
|
||||
; an action name;
|
||||
; a lexer-action name.
|
||||
; lexer-actions-source is a list of lexer-action bindings, each containing:
|
||||
; a lexer-action name;
|
||||
; the type of this lexer-action's value;
|
||||
; the name of a lisp function (char -> value) that performs the lexer-action on a character.
|
||||
; This does not make the lexer's grammar; use make-lexer-and-grammar for that.
|
||||
(defun make-lexer (charclasses-source lexer-actions-source grammar-source)
|
||||
(assert-type charclasses-source (list (tuple nonterminal t (list (tuple identifier identifier)))))
|
||||
(assert-type lexer-actions-source (list (tuple identifier t identifier list)))
|
||||
(let ((lexer-actions (make-hash-table :test #'eq))
|
||||
(charclasses nil)
|
||||
(charclasses-hash (make-hash-table :test *grammar-symbol-=*))
|
||||
(charsets nil)
|
||||
(singletons (grammar-singletons grammar-source)))
|
||||
(let ((lexer-action-number 0))
|
||||
(dolist (lexer-action-source lexer-actions-source)
|
||||
(let ((name (first lexer-action-source))
|
||||
(type-expr (second lexer-action-source))
|
||||
(function (third lexer-action-source))
|
||||
(markup (fourth lexer-action-source)))
|
||||
(when (gethash name lexer-actions)
|
||||
(error "Attempt to redefine lexer action ~S" name))
|
||||
(setf (gethash name lexer-actions)
|
||||
(make-lexer-action name (incf lexer-action-number) type-expr function markup)))))
|
||||
|
||||
(dolist (charclass-source charclasses-source)
|
||||
(let ((nonterminal (first charclass-source))
|
||||
(charset (eval-charset-expr charclasses-hash (ensure-proper-form (second charclass-source))))
|
||||
(actions
|
||||
(mapcar #'(lambda (action-source)
|
||||
(let* ((lexer-action-name (second action-source))
|
||||
(lexer-action (gethash lexer-action-name lexer-actions)))
|
||||
(unless lexer-action
|
||||
(error "Unknown lexer-action ~S" lexer-action-name))
|
||||
(cons (first action-source) lexer-action)))
|
||||
(third charclass-source))))
|
||||
(when (gethash nonterminal charclasses-hash)
|
||||
(error "Attempt to redefine character class ~S" nonterminal))
|
||||
(when (charset-empty? charset)
|
||||
(error "Empty character class ~S" nonterminal))
|
||||
(let ((charclass (make-charclass nonterminal (second charclass-source) charset actions)))
|
||||
(push charclass charclasses)
|
||||
(setf (gethash nonterminal charclasses-hash) charclass)
|
||||
(push charset charsets))))
|
||||
(setq charclasses (nreverse charclasses))
|
||||
(bitmap-each-bit #'(lambda (i) (push (ash 1 i) charsets))
|
||||
singletons)
|
||||
(let ((char-tokens (make-hash-table :test #'eql))
|
||||
(partition-names nil)
|
||||
(partitions (make-hash-table :test #'eq))
|
||||
(current-partition-number 0))
|
||||
(dolist (partition (compute-partitions charsets))
|
||||
(let ((singleton (charset-char partition)))
|
||||
(cond
|
||||
(singleton (setf (gethash singleton char-tokens) singleton))
|
||||
((charset-infinite? partition)
|
||||
(push *default-partition-name* partition-names)
|
||||
(setf (gethash *default-partition-name* partitions)
|
||||
(make-partition partition (collect-lexer-action-names charclasses partition))))
|
||||
(t (let ((token (intern (format nil "$_CHARS~D_" (incf current-partition-number)))))
|
||||
(bitmap-each-bit #'(lambda (i)
|
||||
(setf (gethash (code-char i) char-tokens) token))
|
||||
partition)
|
||||
(push token partition-names)
|
||||
(setf (gethash token partitions)
|
||||
(make-partition partition (collect-lexer-action-names charclasses partition))))))))
|
||||
(allocate-lexer
|
||||
:lexer-actions lexer-actions
|
||||
:charclasses charclasses
|
||||
:charclasses-hash charclasses-hash
|
||||
:char-tokens char-tokens
|
||||
:partition-names (nreverse partition-names)
|
||||
:partitions partitions))))
|
||||
|
||||
|
||||
(defun print-lexer (lexer &optional (stream t))
|
||||
(let* ((lexer-actions (lexer-lexer-actions lexer))
|
||||
(lexer-action-names (sort (hash-table-keys lexer-actions) #'<
|
||||
:key #'(lambda (lexer-action-name)
|
||||
(lexer-action-number (gethash lexer-action-name lexer-actions)))))
|
||||
(charclasses (lexer-charclasses lexer))
|
||||
(partition-names (lexer-partition-names lexer))
|
||||
(partitions (lexer-partitions lexer))
|
||||
(singletons nil))
|
||||
|
||||
(when lexer-action-names
|
||||
(pprint-logical-block (stream lexer-action-names)
|
||||
(format stream "Lexer Actions:~2I")
|
||||
(loop
|
||||
(pprint-newline :mandatory stream)
|
||||
(let ((lexer-action (gethash (pprint-pop) lexer-actions)))
|
||||
(print-lexer-action lexer-action stream))
|
||||
(pprint-exit-if-list-exhausted)))
|
||||
(pprint-newline :mandatory stream)
|
||||
(pprint-newline :mandatory stream))
|
||||
|
||||
(when charclasses
|
||||
(pprint-logical-block (stream charclasses)
|
||||
(format stream "Charclasses:~2I")
|
||||
(loop
|
||||
(pprint-newline :mandatory stream)
|
||||
(let ((charclass (pprint-pop)))
|
||||
(print-charclass charclass stream))
|
||||
(pprint-exit-if-list-exhausted)))
|
||||
(pprint-newline :mandatory stream)
|
||||
(pprint-newline :mandatory stream))
|
||||
|
||||
(when partition-names
|
||||
(pprint-logical-block (stream partition-names)
|
||||
(format stream "Partitions:~2I")
|
||||
(loop
|
||||
(pprint-newline :mandatory stream)
|
||||
(let ((partition-name (pprint-pop)))
|
||||
(print-partition partition-name (gethash partition-name partitions) stream))
|
||||
(pprint-exit-if-list-exhausted)))
|
||||
(pprint-newline :mandatory stream)
|
||||
(pprint-newline :mandatory stream))
|
||||
|
||||
(maphash
|
||||
#'(lambda (char char-or-partition)
|
||||
(if (eql char char-or-partition)
|
||||
(push char singletons)
|
||||
(assert-type char-or-partition identifier)))
|
||||
(lexer-char-tokens lexer))
|
||||
(setq singletons (sort singletons #'char<))
|
||||
(when singletons
|
||||
(format stream "Singletons: ~@_~<~@{~W ~:_~}~:>~:@_~:@_" singletons))))
|
||||
|
||||
|
||||
(defmethod print-object ((lexer lexer) stream)
|
||||
(print-unreadable-object (lexer stream :identity t)
|
||||
(write-string "lexer" stream)))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
|
||||
|
||||
; Return two values:
|
||||
; extra grammar productions that define the character class nonterminals out of characters and tokens;
|
||||
; extra commands that:
|
||||
; define the partitions used in this lexer;
|
||||
; define the actions of these productions.
|
||||
(defun lexer-grammar-and-commands (lexer)
|
||||
(labels
|
||||
((component-partitions (charset partitions)
|
||||
(if (charset-empty? charset)
|
||||
partitions
|
||||
(let* ((partition-name (if (charset-infinite? charset)
|
||||
*default-partition-name*
|
||||
(gethash (charset-highest-char charset) (lexer-char-tokens lexer))))
|
||||
(partition (gethash partition-name (lexer-partitions lexer))))
|
||||
(component-partitions (charset-difference charset (partition-charset partition))
|
||||
(cons partition partitions))))))
|
||||
(let ((productions nil)
|
||||
(commands nil))
|
||||
(dolist (charclass (lexer-charclasses lexer))
|
||||
(let ((nonterminal (charclass-nonterminal charclass))
|
||||
(production-number 0))
|
||||
(dolist (action (charclass-actions charclass))
|
||||
(let ((lexer-action (cdr action)))
|
||||
(push (list 'declare-action (car action) nonterminal (lexer-action-type-expr lexer-action)) commands)))
|
||||
(do ((charset (charclass-charset charclass)))
|
||||
((charset-empty? charset))
|
||||
(let* ((partition-name (if (charset-infinite? charset)
|
||||
*default-partition-name*
|
||||
(gethash (charset-highest-char charset) (lexer-char-tokens lexer))))
|
||||
(partition-charset (if (characterp partition-name)
|
||||
(char-charset partition-name)
|
||||
(partition-charset (gethash partition-name (lexer-partitions lexer)))))
|
||||
(production-name (intern (format nil "~A-~D" nonterminal (incf production-number)))))
|
||||
(push (list nonterminal (list partition-name) production-name) productions)
|
||||
(dolist (action (charclass-actions charclass))
|
||||
(let* ((lexer-action (cdr action))
|
||||
(body (if (characterp partition-name)
|
||||
(let* ((lexer-action-function (lexer-action-function-name lexer-action))
|
||||
(result (funcall lexer-action-function partition-name)))
|
||||
(typecase result
|
||||
(integer result)
|
||||
(character result)
|
||||
((eql nil) 'false)
|
||||
((eql t) 'true)
|
||||
(t (error "Cannot infer the type of ~S's result ~S" lexer-action-function result))))
|
||||
(list (lexer-action-name lexer-action) partition-name))))
|
||||
(push (list 'action (car action) production-name body nil) commands)))
|
||||
(setq charset (charset-difference charset partition-charset))))))
|
||||
|
||||
(let ((partition-commands
|
||||
(mapcan
|
||||
#'(lambda (partition-name)
|
||||
(mapcan #'(lambda (lexer-action)
|
||||
(let ((lexer-action-name (lexer-action-name lexer-action)))
|
||||
(list
|
||||
(list 'declare-action lexer-action-name partition-name (lexer-action-type-expr lexer-action))
|
||||
(list 'terminal-action lexer-action-name partition-name (lexer-action-function-name lexer-action)))))
|
||||
(partition-lexer-actions (gethash partition-name (lexer-partitions lexer)))))
|
||||
(lexer-partition-names lexer))))
|
||||
(values
|
||||
(nreverse productions)
|
||||
(nconc partition-commands (nreverse commands)))))))
|
||||
|
||||
|
||||
; Make a lexer and grammar from the given source.
|
||||
; kind should be either :lalr-1 or :lr-1.
|
||||
; charclasses-source is a list of character classes, and
|
||||
; lexer-actions-source is a list of lexer-action bindings; see make-lexer.
|
||||
; start-symbol is the grammar's start symbol, and grammar-source is its source.
|
||||
; Return two values:
|
||||
; the lexer (including the grammar in its grammar field);
|
||||
; list of extra commands that:
|
||||
; define the partitions used in this lexer;
|
||||
; define the actions of these productions.
|
||||
(defun make-lexer-and-grammar (kind charclasses-source lexer-actions-source parametrization start-symbol grammar-source)
|
||||
(let ((lexer (make-lexer charclasses-source lexer-actions-source grammar-source)))
|
||||
(multiple-value-bind (extra-grammar-source extra-commands) (lexer-grammar-and-commands lexer)
|
||||
(let ((grammar (make-and-compile-grammar kind parametrization start-symbol (append extra-grammar-source grammar-source))))
|
||||
(setf (lexer-grammar lexer) grammar)
|
||||
(values lexer extra-commands)))))
|
||||
|
||||
|
||||
; Parse the input string to produce a list of action results.
|
||||
; If trace is:
|
||||
; nil, don't print trace information
|
||||
; :code, print trace information, including action code
|
||||
; other print trace information
|
||||
; Return two values:
|
||||
; the list of action results;
|
||||
; the list of action results' types.
|
||||
(defun lexer-parse (lexer string &key trace)
|
||||
(let ((in (coerce string 'list)))
|
||||
(action-parse (lexer-grammar lexer) (lexer-classifier lexer) in :trace trace)))
|
||||
|
||||
|
||||
; Same as lexer-parse except that also print the action results nicely.
|
||||
(defun lexer-pparse (lexer string &key (stream t) trace)
|
||||
(multiple-value-bind (results types) (lexer-parse lexer string :trace trace)
|
||||
(print-values results types stream)
|
||||
(terpri stream)
|
||||
(values results types)))
|
||||
|
||||
|
||||
; Compute the lexer grammar's metagrammar.
|
||||
(defun set-up-lexer-metagrammar (lexer)
|
||||
(setf (lexer-metagrammar lexer) (make-metagrammar (lexer-grammar lexer))))
|
||||
|
||||
|
||||
|
||||
; Parse the input string into elements, where each element is the longest
|
||||
; possible string of input characters that is accepted by the grammar.
|
||||
; The grammar's terminals are all characters that may appear in the input
|
||||
; string plus the symbol $END which is inserted after the last character of
|
||||
; the string.
|
||||
; Return the list of lists of action results of the elements.
|
||||
; If trace is:
|
||||
; nil, don't print trace information
|
||||
; :code, print trace information, including action code
|
||||
; other print trace information
|
||||
; Return two values:
|
||||
; the list of lists of action results;
|
||||
; the list of action results' types. Each of the lists of action results has
|
||||
; this type signature.
|
||||
(defun lexer-metaparse (lexer string &key trace)
|
||||
(let ((metagrammar (lexer-metagrammar lexer)))
|
||||
(do ((in (append (coerce string 'list) '($end)))
|
||||
(results-lists nil))
|
||||
((endp in) (values (nreverse results-lists) (grammar-user-start-action-types (metagrammar-grammar metagrammar))))
|
||||
(multiple-value-bind (results in-rest) (action-metaparse metagrammar (lexer-classifier lexer) in :trace trace)
|
||||
(setq in in-rest)
|
||||
(push results results-lists)))))
|
||||
|
||||
|
||||
; Same as lexer-metaparse except that also print the action results nicely.
|
||||
(defun lexer-pmetaparse (lexer string &key (stream t) trace)
|
||||
(multiple-value-bind (results-lists types) (lexer-metaparse lexer string :trace trace)
|
||||
(pprint-logical-block (stream results-lists)
|
||||
(pprint-exit-if-list-exhausted)
|
||||
(loop
|
||||
(print-values (pprint-pop) types stream :prefix "(" :suffix ")")
|
||||
(pprint-exit-if-list-exhausted)
|
||||
(format stream " ~_")))
|
||||
(terpri stream)
|
||||
(values results-lists types)))
|
||||
|
||||
|
|
@ -0,0 +1,42 @@
|
|||
;;; The contents of this file are subject to the Netscape Public License
|
||||
;;; Version 1.0 (the "NPL"); you may not use this file except in
|
||||
;;; compliance with the NPL. You may obtain a copy of the NPL at
|
||||
;;; http://www.mozilla.org/NPL/
|
||||
;;;
|
||||
;;; Software distributed under the NPL is distributed on an "AS IS" basis,
|
||||
;;; WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
|
||||
;;; for the specific language governing rights and limitations under the
|
||||
;;; NPL.
|
||||
;;;
|
||||
;;; The Initial Developer of this code under the NPL is Netscape
|
||||
;;; Communications Corporation. Portions created by Netscape are
|
||||
;;; Copyright (C) 1998 Netscape Communications Corporation. All Rights
|
||||
;;; Reserved.
|
||||
|
||||
;;;
|
||||
;;; ECMAScript semantic loader
|
||||
;;;
|
||||
;;; Waldemar Horwat (waldemar@netscape.com)
|
||||
;;;
|
||||
|
||||
|
||||
(defparameter *semantic-engine-filenames*
|
||||
'("Utilities" "Markup" "RTF" "HTML" "GrammarSymbol" "Grammar" "Parser" "Metaparser" "Lexer" "Calculus" "CalculusMarkup" "JS14" "ECMA Lexer" "ECMA Grammar"))
|
||||
|
||||
(defparameter *semantic-engine-directory*
|
||||
(make-pathname
|
||||
:directory (pathname-directory (truename *loading-file-source-file*))))
|
||||
|
||||
(defun load-semantic-engine ()
|
||||
(dolist (filename *semantic-engine-filenames*)
|
||||
(let ((pathname (merge-pathnames filename *semantic-engine-directory*)))
|
||||
(load pathname :verbose t))))
|
||||
|
||||
(defmacro with-local-output ((stream filename) &body body)
|
||||
`(with-open-file (,stream (merge-pathnames ,filename *semantic-engine-directory*)
|
||||
:direction :output
|
||||
:if-exists :supersede)
|
||||
,@body))
|
||||
|
||||
|
||||
(load-semantic-engine)
|
||||
|
|
@ -0,0 +1,508 @@
|
|||
;;; The contents of this file are subject to the Netscape Public License
|
||||
;;; Version 1.0 (the "NPL"); you may not use this file except in
|
||||
;;; compliance with the NPL. You may obtain a copy of the NPL at
|
||||
;;; http://www.mozilla.org/NPL/
|
||||
;;;
|
||||
;;; Software distributed under the NPL is distributed on an "AS IS" basis,
|
||||
;;; WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
|
||||
;;; for the specific language governing rights and limitations under the
|
||||
;;; NPL.
|
||||
;;;
|
||||
;;; The Initial Developer of this code under the NPL is Netscape
|
||||
;;; Communications Corporation. Portions created by Netscape are
|
||||
;;; Copyright (C) 1999 Netscape Communications Corporation. All Rights
|
||||
;;; Reserved.
|
||||
|
||||
;;;
|
||||
;;; Common RTF and HTML writing utilities
|
||||
;;;
|
||||
;;; Waldemar Horwat (waldemar@netscape.com)
|
||||
;;;
|
||||
|
||||
|
||||
(defvar *trace-logical-blocks* nil) ;Emit logical blocks to *trace-output* while processing
|
||||
(defvar *show-logical-blocks* nil) ;Emit logical block boundaries as hidden rtf text
|
||||
|
||||
(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
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; MARKUP ENVIRONMENTS
|
||||
|
||||
|
||||
(defstruct (markup-env (:constructor allocate-markup-env (macros widths)))
|
||||
(macros nil :type hash-table :read-only t) ;Hash table of keyword -> expansion list
|
||||
(widths nil :type hash-table :read-only t)) ;Hash table of keyword -> estimated width of macro expansion;
|
||||
; ; zero-width entries can be omitted; multiline entries have t for a width.
|
||||
|
||||
|
||||
(defun make-markup-env ()
|
||||
(allocate-markup-env (make-hash-table :test #'eq) (make-hash-table :test #'eq)))
|
||||
|
||||
|
||||
; Recursively expand all keywords in markup-tree, producing a freshly consed expansion tree.
|
||||
; Allow keywords in the permitted-keywords list to be present in the output without generating an error.
|
||||
(defun markup-env-expand (markup-env markup-tree permitted-keywords)
|
||||
(mapcan
|
||||
#'(lambda (markup-element)
|
||||
(cond
|
||||
((keywordp markup-element)
|
||||
(let ((expansion (gethash markup-element (markup-env-macros markup-env) *get2-nonce*)))
|
||||
(if (eq expansion *get2-nonce*)
|
||||
(if (member markup-element permitted-keywords :test #'eq)
|
||||
(list markup-element)
|
||||
(error "Unknown markup macro ~S" markup-element))
|
||||
(markup-env-expand markup-env expansion permitted-keywords))))
|
||||
((listp markup-element)
|
||||
(list (markup-env-expand markup-env markup-element permitted-keywords)))
|
||||
(t (list markup-element))))
|
||||
markup-tree))
|
||||
|
||||
|
||||
(defun markup-env-define (markup-env keyword expansion &optional width)
|
||||
(assert-type keyword keyword)
|
||||
(assert-type expansion (list t))
|
||||
(assert-type width (or null integer (eql t)))
|
||||
(when (gethash keyword (markup-env-macros markup-env))
|
||||
(warn "Redefining markup macro ~S" keyword))
|
||||
(setf (gethash keyword (markup-env-macros markup-env)) expansion)
|
||||
(if width
|
||||
(setf (gethash keyword (markup-env-widths markup-env)) width)
|
||||
(remhash keyword (markup-env-widths markup-env))))
|
||||
|
||||
|
||||
(defun markup-env-append (markup-env keyword expansion)
|
||||
(assert-type keyword keyword)
|
||||
(assert-type expansion (list t))
|
||||
(setf (gethash keyword (markup-env-macros markup-env))
|
||||
(append (gethash keyword (markup-env-macros markup-env)) expansion)))
|
||||
|
||||
|
||||
(defun markup-env-define-alist (markup-env keywords-and-expansions)
|
||||
(dolist (keyword-and-expansion keywords-and-expansions)
|
||||
(let ((keyword (car keyword-and-expansion))
|
||||
(expansion (cdr keyword-and-expansion)))
|
||||
(cond
|
||||
((not (consp keyword))
|
||||
(markup-env-define markup-env keyword expansion))
|
||||
((eq (first keyword) '+)
|
||||
(markup-env-append markup-env (second keyword) expansion))
|
||||
(t (markup-env-define markup-env (first keyword) expansion (second keyword)))))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; LOGICAL POSITIONS
|
||||
|
||||
(defstruct logical-position
|
||||
(n-hard-breaks 0 :type integer) ;Number of :new-line's in the current paragraph or logical block
|
||||
(position 0 :type integer) ;Current character position. If n-hard-breaks is zero, only includes characters written into this logical block
|
||||
; ; plus the minimal position from the enclosing block. If n-hard-breaks is nonzero, includes indent and characters
|
||||
; ; written since the last hard break.
|
||||
(surplus 0 :type integer) ;Value to subtract from position if soft breaks were hard breaks in this logical block
|
||||
(n-soft-breaks nil :type (or null integer)) ;Number of soft-breaks in the current paragraph or nil if not inside a depict-logical-block
|
||||
(indent 0 :type (or null integer))) ;Indent for next line
|
||||
|
||||
|
||||
; Return the value the position would have if soft breaks became hard breaks in this logical block.
|
||||
(declaim (inline logical-position-minimal-position))
|
||||
(defun logical-position-minimal-position (logical-position)
|
||||
(- (logical-position-position logical-position) (logical-position-surplus logical-position)))
|
||||
|
||||
|
||||
; Advance the logical position by width characters. If width is t,
|
||||
; advance to the next line.
|
||||
(defun logical-position-advance (logical-position width)
|
||||
(if (eq width t)
|
||||
(progn
|
||||
(incf (logical-position-n-hard-breaks logical-position))
|
||||
(setf (logical-position-position logical-position) 0)
|
||||
(setf (logical-position-surplus logical-position) 0))
|
||||
(incf (logical-position-position logical-position) width)))
|
||||
|
||||
|
||||
(defstruct (soft-break (:constructor make-soft-break (width)))
|
||||
(width 0 :type integer)) ;Number of spaces by which to replace this soft break if it doesn't turn into a hard break; t if unconditional
|
||||
|
||||
|
||||
; Destructively replace any soft-break that appears in a car position in the tree with
|
||||
; the spliced result of calling f on that soft-break. f should return a non-null list that can
|
||||
; be nconc'd.
|
||||
(defun substitute-soft-breaks (tree f)
|
||||
(do ((subtree tree next-subtree)
|
||||
(next-subtree (cdr tree) (cdr next-subtree)))
|
||||
((endp subtree))
|
||||
(let ((item (car subtree)))
|
||||
(cond
|
||||
((soft-break-p item)
|
||||
(let* ((splice (assert-non-null (funcall f item)))
|
||||
(splice-rest (cdr splice)))
|
||||
(setf (car subtree) (car splice))
|
||||
(setf (cdr subtree) (nconc splice-rest next-subtree))))
|
||||
((consp item) (substitute-soft-breaks item f)))))
|
||||
tree)
|
||||
|
||||
|
||||
; Destructively replace any soft-break that appears in a car position in the tree
|
||||
; with width spaces, where width is the soft-break's width.
|
||||
(defun remove-soft-breaks (tree)
|
||||
(substitute-soft-breaks
|
||||
tree
|
||||
#'(lambda (soft-break)
|
||||
(list (make-string (soft-break-width soft-break) :initial-element #\space :element-type 'base-character)))))
|
||||
|
||||
|
||||
; 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 'base-character))))
|
||||
|
||||
|
||||
; Destructively replace any soft-break that appears in a car position in the tree
|
||||
; with a line break followed by indent spaces.
|
||||
(defun expand-soft-breaks (tree indent)
|
||||
(substitute-soft-breaks
|
||||
tree
|
||||
#'(lambda (soft-break)
|
||||
(declare (ignore soft-break))
|
||||
(hard-break-markup indent))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; MARKUP STREAMS
|
||||
|
||||
(defstruct (markup-stream (:copier nil) (:predicate markup-stream?))
|
||||
(env nil :type markup-env :read-only t)
|
||||
(level nil :type integer) ;0 for emitting top-level group; 1 for emitting sections; 2 for emitting paragraphs; 3 for emitting paragraph contents
|
||||
(head nil :type list) ;Pointer to a dummy cons-cell whose cdr is the output markup list.
|
||||
; ; 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-position nil :type logical-position)) ;Information about the current logical lines or nil if not emitting paragraph contents
|
||||
|
||||
; ;RTF ;HTML
|
||||
(defconstant *markup-stream-top-level* 0) ;Top-level group ;Top level
|
||||
(defconstant *markup-stream-section-level* 1) ;Sections ;(not used)
|
||||
(defconstant *markup-stream-paragraph-level* 2) ;Paragraphs ;Block tags
|
||||
(defconstant *markup-stream-content-level* 3) ;Paragraph contents ;Inline tags
|
||||
|
||||
|
||||
; 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)
|
||||
(when (markup-stream-pretail markup-stream)
|
||||
;Inline the last block at the end of the markup-stream.
|
||||
(setf (cdr (markup-stream-pretail markup-stream)) (car (markup-stream-tail markup-stream)))
|
||||
(setf (markup-stream-pretail markup-stream) nil))
|
||||
(setf (markup-stream-tail markup-stream) nil) ;Close the stream.
|
||||
(cdr (assert-non-null (markup-stream-head markup-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.
|
||||
(defgeneric markup-stream-output (markup-stream))
|
||||
|
||||
|
||||
; Append one item to the end of the markup-stream.
|
||||
(defun markup-stream-append1 (markup-stream item)
|
||||
(setf (markup-stream-pretail markup-stream) nil)
|
||||
(let ((item-cons (list item)))
|
||||
(setf (cdr (markup-stream-tail markup-stream)) item-cons)
|
||||
(setf (markup-stream-tail markup-stream) item-cons)))
|
||||
|
||||
|
||||
; Return the approximate width of the markup item; return t if it is a line break.
|
||||
(defun markup-width (markup-stream item)
|
||||
(cond
|
||||
((stringp item) (round (- (length item) (* (count #\space item) (- 1 *average-space-width*)))))
|
||||
((keywordp item) (gethash item (markup-env-widths (markup-stream-env markup-stream)) 0))
|
||||
((and item (symbolp item)) 0)
|
||||
(t (error "Bad item in markup-width" item))))
|
||||
|
||||
|
||||
; Return the approximate width of the markup item; return t if it is a line break.
|
||||
; Also allow markup groups as long as they do not contain line breaks.
|
||||
(defgeneric markup-group-width (markup-stream item))
|
||||
|
||||
|
||||
; Append zero or more markup items to the end of the markup-stream.
|
||||
; The items must be either keywords, symbols, or strings.
|
||||
(defun depict (markup-stream &rest markup-list)
|
||||
(assert-true (>= (markup-stream-level markup-stream) *markup-stream-content-level*))
|
||||
(dolist (markup markup-list)
|
||||
(markup-stream-append1 markup-stream markup)
|
||||
(logical-position-advance (markup-stream-logical-position markup-stream) (markup-width markup-stream markup))))
|
||||
|
||||
|
||||
; Same as depict except that the items may be groups as well.
|
||||
(defun depict-group (markup-stream &rest markup-list)
|
||||
(assert-true (>= (markup-stream-level markup-stream) *markup-stream-content-level*))
|
||||
(dolist (markup markup-list)
|
||||
(markup-stream-append1 markup-stream markup)
|
||||
(logical-position-advance (markup-stream-logical-position markup-stream) (markup-group-width markup-stream markup))))
|
||||
|
||||
|
||||
; If markup-item-or-list is a list, emit its contents via depict.
|
||||
; If markup-item-or-list is not a list, emit it via depict.
|
||||
(defun depict-item-or-list (markup-stream markup-item-or-list)
|
||||
(if (listp markup-item-or-list)
|
||||
(apply #'depict markup-stream markup-item-or-list)
|
||||
(depict markup-stream markup-item-or-list)))
|
||||
|
||||
|
||||
; If markup-item-or-list is a list, emit its contents via depict-group.
|
||||
; If markup-item-or-list is not a list, emit it via depict.
|
||||
(defun depict-item-or-group-list (markup-stream markup-item-or-list)
|
||||
(if (listp markup-item-or-list)
|
||||
(apply #'depict-group markup-stream markup-item-or-list)
|
||||
(depict markup-stream markup-item-or-list)))
|
||||
|
||||
|
||||
; 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 block-style is applied to all
|
||||
; paragraphs emitted by body (in the HTML emitter only; RTF has no block styles).
|
||||
; Return the result value of body.
|
||||
(defmacro depict-block-style ((markup-stream block-style) &body body)
|
||||
`(depict-block-style-f ,markup-stream ,block-style
|
||||
#'(lambda (,markup-stream) ,@body)))
|
||||
|
||||
(defgeneric depict-block-style-f (markup-stream block-style emitter))
|
||||
|
||||
|
||||
; markup-stream must be a variable that names a markup-stream that is currently
|
||||
; accepting paragraphs. Emit a paragraph with the given paragraph-style (which
|
||||
; must be a symbol) whose contents are emitted by body. When executing body,
|
||||
; markup-stream is bound to a markup-stream to which body should emit the paragraph's contents.
|
||||
; Return the result value of body.
|
||||
(defmacro depict-paragraph ((markup-stream paragraph-style) &body body)
|
||||
`(depict-paragraph-f ,markup-stream ,paragraph-style
|
||||
#'(lambda (,markup-stream) ,@body)))
|
||||
|
||||
(defgeneric depict-paragraph-f (markup-stream paragraph-style emitter))
|
||||
|
||||
|
||||
; markup-stream must be a variable that names a markup-stream that is currently
|
||||
; accepting paragraph contents. Execute body with markup-stream bound to a markup-stream
|
||||
; to which the body can emit contents. The given char-style is applied to all such
|
||||
; contents emitted by body.
|
||||
; Return the result value of body.
|
||||
(defmacro depict-char-style ((markup-stream char-style) &body body)
|
||||
`(depict-char-style-f ,markup-stream ,char-style
|
||||
#'(lambda (,markup-stream) ,@body)))
|
||||
|
||||
(defgeneric depict-char-style-f (markup-stream char-style emitter))
|
||||
|
||||
|
||||
(defun depict-logical-block-f (markup-stream indent emitter)
|
||||
(assert-true (>= (markup-stream-level markup-stream) *markup-stream-content-level*))
|
||||
(if indent
|
||||
(let* ((logical-position (markup-stream-logical-position markup-stream))
|
||||
(cumulative-indent (+ (logical-position-indent logical-position) indent))
|
||||
(minimal-position (logical-position-minimal-position logical-position))
|
||||
(inner-logical-position (make-logical-position :position minimal-position
|
||||
:n-soft-breaks 0
|
||||
:indent cumulative-indent))
|
||||
(old-tail (markup-stream-tail markup-stream)))
|
||||
(setf (markup-stream-logical-position markup-stream) inner-logical-position)
|
||||
(when *show-logical-blocks*
|
||||
(markup-stream-append1 markup-stream (list ':invisible (format nil "<~D" indent))))
|
||||
(prog1
|
||||
(funcall emitter markup-stream)
|
||||
(when *show-logical-blocks*
|
||||
(markup-stream-append1 markup-stream '(:invisible ">")))
|
||||
(assert-true (eq (markup-stream-logical-position markup-stream) inner-logical-position))
|
||||
(let* ((tree (cdr old-tail))
|
||||
(inner-position (logical-position-position inner-logical-position))
|
||||
(inner-count (- inner-position minimal-position))
|
||||
(inner-n-hard-breaks (logical-position-n-hard-breaks inner-logical-position))
|
||||
(inner-n-soft-breaks (logical-position-n-soft-breaks inner-logical-position)))
|
||||
(when *trace-logical-blocks*
|
||||
(format *trace-output* "Block ~:W:~%position ~D, count ~D, n-hard-breaks ~D, n-soft-breaks ~D~%~%"
|
||||
tree inner-position inner-count inner-n-hard-breaks inner-n-soft-breaks))
|
||||
(cond
|
||||
((zerop inner-n-soft-breaks)
|
||||
(assert-true (zerop (logical-position-surplus inner-logical-position)))
|
||||
(if (zerop inner-n-hard-breaks)
|
||||
(incf (logical-position-position logical-position) inner-count)
|
||||
(progn
|
||||
(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*))
|
||||
(assert-true tree)
|
||||
(remove-soft-breaks tree)
|
||||
(incf (logical-position-position logical-position) inner-count))
|
||||
(t
|
||||
(assert-true tree)
|
||||
(expand-soft-breaks tree cumulative-indent)
|
||||
(incf (logical-position-n-hard-breaks logical-position) (+ inner-n-hard-breaks inner-n-soft-breaks))
|
||||
(setf (logical-position-position logical-position) (logical-position-minimal-position inner-logical-position))
|
||||
(setf (logical-position-surplus logical-position) 0))))
|
||||
(setf (markup-stream-logical-position markup-stream) logical-position)))
|
||||
(funcall emitter markup-stream)))
|
||||
|
||||
|
||||
; markup-stream must be a variable that names a markup-stream that is currently
|
||||
; accepting paragraph contents. Execute body with markup-stream bound to a markup-stream
|
||||
; to which the body can emit contents. body can call depict-break, which will either
|
||||
; all expand to the widths given to the depict-break calls or all expand to line breaks
|
||||
; followed by indents to the current indent level plus the given indent.
|
||||
; If indent is nil, don't create the logical block and just evaluate body.
|
||||
; Return the result value of body.
|
||||
(defmacro depict-logical-block ((markup-stream indent) &body body)
|
||||
`(depict-logical-block-f ,markup-stream ,indent
|
||||
#'(lambda (,markup-stream) ,@body)))
|
||||
|
||||
|
||||
; Emit a conditional line break. If the line break is not needed, emit width spaces instead.
|
||||
; If width is t or omitted, the line break is unconditional.
|
||||
; If width is nil, do nothing.
|
||||
; If the line break is needed, the new line is indented to the current indent level.
|
||||
; Must be called from the dynamic scope of a depict-logical-block.
|
||||
(defun depict-break (markup-stream &optional (width t))
|
||||
(assert-true (>= (markup-stream-level markup-stream) *markup-stream-content-level*))
|
||||
(when width
|
||||
(let* ((logical-position (markup-stream-logical-position markup-stream))
|
||||
(indent (logical-position-indent logical-position)))
|
||||
(if (eq width t)
|
||||
(depict-item-or-list markup-stream (hard-break-markup indent))
|
||||
(progn
|
||||
(incf (logical-position-n-soft-breaks logical-position))
|
||||
(incf (logical-position-position logical-position) width)
|
||||
(let ((surplus (- (logical-position-position logical-position) (round (* indent *average-space-width*)))))
|
||||
(when (< surplus 0)
|
||||
(setq surplus 0))
|
||||
(setf (logical-position-surplus logical-position) surplus))
|
||||
(when *show-logical-blocks*
|
||||
(markup-stream-append1 markup-stream '(:invisible :bullet)))
|
||||
(markup-stream-append1 markup-stream (make-soft-break width)))))))
|
||||
|
||||
|
||||
; Call emitter to emit each element of the given list onto the markup-stream.
|
||||
; emitter takes two arguments -- the markup-stream and the element of list to be emitted.
|
||||
; Emit prefix before the list and suffix after the list. If prefix-break is supplied, call
|
||||
; depict-break with it as the argument after the prefix.
|
||||
; If indent is non-nil, enclose the list elements in a logical block with the given indent.
|
||||
; Emit separator between any two emitted elements. If break is supplied, call
|
||||
; depict-break with it as the argument after each separator.
|
||||
; If the list is empty, emit empty unless it is :error, in which case signal an error.
|
||||
;
|
||||
; prefix, suffix, separator, and empty should be lists of markup elements appropriate for depict.
|
||||
; If any of these lists has only one element that is not itself a list, then that list can be
|
||||
; abbreviated to just that element (as in depict-item-or-list).
|
||||
;
|
||||
(defun depict-list (markup-stream emitter list &key indent prefix prefix-break suffix separator break (empty :error))
|
||||
(assert-true (or indent (not (or prefix-break break))))
|
||||
(labels
|
||||
((emit-element (markup-stream list)
|
||||
(funcall emitter markup-stream (first list))
|
||||
(let ((rest (rest list)))
|
||||
(when rest
|
||||
(depict-item-or-list markup-stream separator)
|
||||
(depict-break markup-stream break)
|
||||
(emit-element markup-stream rest)))))
|
||||
|
||||
(depict-item-or-list markup-stream prefix)
|
||||
(cond
|
||||
(list
|
||||
(depict-logical-block (markup-stream indent)
|
||||
(depict-break markup-stream prefix-break)
|
||||
(emit-element markup-stream list)))
|
||||
((eq empty ':error) (error "Non-empty list required"))
|
||||
(t (depict-item-or-list markup-stream empty)))
|
||||
(depict-item-or-list markup-stream suffix)))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; MARKUP FOR CHARACTERS AND STRINGS
|
||||
|
||||
(defparameter *character-names*
|
||||
'((#x00 . "NUL")
|
||||
(#x08 . "BS")
|
||||
(#x09 . "TAB")
|
||||
(#x0A . "LF")
|
||||
(#x0B . "VT")
|
||||
(#x0C . "FF")
|
||||
(#x0D . "CR")
|
||||
(#x20 . "SP")))
|
||||
|
||||
; Emit markup for the given character. The character is emitted without any formatting if it is a
|
||||
; printable character and not a member of the escape-list list of characters. Otherwise the
|
||||
; character is emitted with :character-literal-control formatting.
|
||||
; The markup-stream should already be set to :character-literal formatting.
|
||||
(defun depict-character (markup-stream char &optional (escape-list '(#\space)))
|
||||
(let ((code (char-code char)))
|
||||
(if (and (>= code 32) (< code 127) (not (member char escape-list)))
|
||||
(depict markup-stream (string char))
|
||||
(depict-char-style (markup-stream ':character-literal-control)
|
||||
(let ((name (or (cdr (assoc code *character-names*))
|
||||
(format nil "u~4,'0X" code))))
|
||||
(depict markup-stream ':left-angle-quote name ':right-angle-quote))))))
|
||||
|
||||
|
||||
; Emit markup for the given string, enclosing it in curly double quotes.
|
||||
; The markup-stream should be set to normal formatting.
|
||||
(defun depict-string (markup-stream string)
|
||||
(depict markup-stream ':left-double-quote)
|
||||
(unless (equal string "")
|
||||
(depict-char-style (markup-stream ':character-literal)
|
||||
(dotimes (i (length string))
|
||||
(depict-character markup-stream (char string i) nil))))
|
||||
(depict markup-stream ':right-double-quote))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; MARKUP FOR IDENTIFIERS
|
||||
|
||||
; Return string converted from dash-separated-uppercase-words to mixed case,
|
||||
; with the first character capitalized if capitalize is true.
|
||||
; The string should contain only letters, dashes, and numbers.
|
||||
(defun string-to-mixed-case (string &optional capitalize)
|
||||
(let* ((length (length string))
|
||||
(dst-string (make-array length :element-type 'base-character :fill-pointer 0)))
|
||||
(dotimes (i length)
|
||||
(let ((char (char string i)))
|
||||
(if (eql char #\-)
|
||||
(if capitalize
|
||||
(error "Double capitalize")
|
||||
(setq capitalize t))
|
||||
(progn
|
||||
(cond
|
||||
((upper-case-p char)
|
||||
(if capitalize
|
||||
(setq capitalize nil)
|
||||
(setq char (char-downcase char))))
|
||||
((digit-char-p char))
|
||||
((member char '(#\$ #\_)))
|
||||
(t (error "Bad string-to-mixed-case character ~A" char)))
|
||||
(vector-push char dst-string)))))
|
||||
dst-string))
|
||||
|
||||
|
||||
; Return a string containing the symbol's name in mixed case with the first letter capitalized.
|
||||
(defun symbol-upper-mixed-case-name (symbol)
|
||||
(or (get symbol :upper-mixed-case-name)
|
||||
(setf (get symbol :upper-mixed-case-name) (string-to-mixed-case (symbol-name symbol) t))))
|
||||
|
||||
|
||||
; Return a string containing the symbol's name in mixed case with the first letter in lower case.
|
||||
(defun symbol-lower-mixed-case-name (symbol)
|
||||
(or (get symbol :lower-mixed-case-name)
|
||||
(setf (get symbol :lower-mixed-case-name) (string-to-mixed-case (symbol-name symbol)))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; MISCELLANEOUS MARKUP
|
||||
|
||||
|
||||
; Append a space to the end of the markup-stream.
|
||||
(defun depict-space (markup-stream)
|
||||
(depict markup-stream " "))
|
||||
|
||||
|
||||
; Emit markup for the given integer, displaying it in decimal.
|
||||
(defun depict-integer (markup-stream i)
|
||||
(depict markup-stream (format nil "~D" i)))
|
||||
|
||||
|
|
@ -0,0 +1,356 @@
|
|||
;;; The contents of this file are subject to the Netscape Public License
|
||||
;;; Version 1.0 (the "NPL"); you may not use this file except in
|
||||
;;; compliance with the NPL. You may obtain a copy of the NPL at
|
||||
;;; http://www.mozilla.org/NPL/
|
||||
;;;
|
||||
;;; Software distributed under the NPL is distributed on an "AS IS" basis,
|
||||
;;; WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
|
||||
;;; for the specific language governing rights and limitations under the
|
||||
;;; NPL.
|
||||
;;;
|
||||
;;; The Initial Developer of this code under the NPL is Netscape
|
||||
;;; Communications Corporation. Portions created by Netscape are
|
||||
;;; Copyright (C) 1998 Netscape Communications Corporation. All Rights
|
||||
;;; Reserved.
|
||||
|
||||
;;;
|
||||
;;; Finite-state machine generator
|
||||
;;;
|
||||
;;; Waldemar Horwat (waldemar@netscape.com)
|
||||
;;;
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; METATRANSITION
|
||||
|
||||
(defstruct (metatransition (:constructor make-metatransition (next-metastate pre-productions post-productions)))
|
||||
(next-metastate nil :read-only t) ;Next metastate to enter or nil if this is an accept transition
|
||||
(pre-productions nil :read-only t) ;List of productions reduced by this transition (in order from first to last) before the shift
|
||||
(post-productions nil :read-only t)) ;List of productions reduced by this transition (in order from first to last) after the shift
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; METASTATE
|
||||
|
||||
;;; A metastate is a list of states that represents a possible stack that the
|
||||
;;; LALR(1) parser may encounter.
|
||||
(defstruct (metastate (:constructor make-metastate (stack number transitions)))
|
||||
(stack nil :type list :read-only t) ;List of states that comprises a possible stack
|
||||
(number nil :type integer :read-only t) ;Serial number of this metastate
|
||||
(transitions nil :type simple-vector :read-only t)) ;Array, indexed by terminal numbers, of either nil or metatransition structures
|
||||
|
||||
(declaim (inline metastate-transition))
|
||||
(defun metastate-transition (metastate terminal-number)
|
||||
(svref (metastate-transitions metastate) terminal-number))
|
||||
|
||||
|
||||
(defun print-metastate (metastate metagrammar &optional (stream t))
|
||||
(let ((grammar (metagrammar-grammar metagrammar)))
|
||||
(pprint-logical-block (stream nil)
|
||||
(format stream "M~D:~2I ~@_~<~@{S~D ~:_~}~:>~:@_"
|
||||
(metastate-number metastate)
|
||||
(nreverse (mapcar #'state-number (metastate-stack metastate))))
|
||||
(let ((transitions (metastate-transitions metastate)))
|
||||
(dotimes (terminal-number (length transitions))
|
||||
(let ((transition (svref transitions terminal-number))
|
||||
(terminal (svref (grammar-terminals grammar) terminal-number)))
|
||||
(when transition
|
||||
(let ((next-metastate (metatransition-next-metastate transition)))
|
||||
(pprint-logical-block (stream nil)
|
||||
(format stream "~W ==> ~@_~:I~:[accept~;M~:*~D~] ~_"
|
||||
terminal
|
||||
(and next-metastate (metastate-number next-metastate)))
|
||||
(pprint-fill stream (mapcar #'production-name (metatransition-pre-productions transition)))
|
||||
(format stream " ~@_")
|
||||
(pprint-fill stream (mapcar #'production-name (metatransition-post-productions transition))))
|
||||
(pprint-newline :mandatory stream)))))))))
|
||||
|
||||
|
||||
(defmethod print-object ((metastate metastate) stream)
|
||||
(print-unreadable-object (metastate stream)
|
||||
(format stream "metastate S~D" (metastate-number metastate))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; METAGRAMMAR
|
||||
|
||||
(defstruct (metagrammar (:constructor allocate-metagrammar))
|
||||
(grammar nil :type grammar :read-only t) ;The grammar to which this metagrammar corresponds
|
||||
(metastates nil :type list :read-only t) ;List of metastates ordered by metastate numbers
|
||||
(start nil :type metastate :read-only t)) ;The start metastate
|
||||
|
||||
|
||||
(defun make-metagrammar (grammar)
|
||||
(let* ((terminals (grammar-terminals grammar))
|
||||
(n-terminals (length terminals))
|
||||
(metastates-hash (make-hash-table :test #'equal)) ;Hash table of (list of state) -> metastate
|
||||
(metastates nil)
|
||||
(metastate-number -1))
|
||||
(labels
|
||||
(;Return the stack after applying the given reduction production.
|
||||
(apply-reduction-production (stack production)
|
||||
(let* ((stack (nthcdr (production-rhs-length production) stack))
|
||||
(state (first stack))
|
||||
(dst-state (assert-non-null
|
||||
(cdr (assoc (production-lhs production) (state-gotos state) :test *grammar-symbol-=*))))
|
||||
(dst-stack (cons dst-state stack)))
|
||||
(if (member dst-state stack :test #'eq)
|
||||
(error "This grammar cannot be represented by a FSM. Stack: ~S" dst-stack)
|
||||
dst-stack)))
|
||||
|
||||
(get-metatransition (stack terminal productions)
|
||||
(let* ((state (first stack))
|
||||
(transition (cdr (assoc terminal (state-transitions state) :test *grammar-symbol-=*))))
|
||||
(when transition
|
||||
(case (transition-kind transition)
|
||||
(:shift
|
||||
(multiple-value-bind (metastate forwarding-productions) (get-metastate (transition-state transition) stack t)
|
||||
(make-metatransition metastate (nreverse productions) forwarding-productions)))
|
||||
(:reduce
|
||||
(let ((production (transition-production transition)))
|
||||
(get-metatransition (apply-reduction-production stack production) terminal (cons production productions))))
|
||||
(:accept (make-metatransition nil (nreverse productions) nil))
|
||||
(t (error "Bad transition: ~S" transition))))))
|
||||
|
||||
;Return the metastate corresponding to the state stack (stack-top . stack-rest). Construct a new
|
||||
;metastate if necessary.
|
||||
;If simplify is true and stack-top is a state for which every outgoing transition is the same
|
||||
;reduction, return two values:
|
||||
; the metastate reached by following that reduction (doing it recursively if needed)
|
||||
; a list of reduction productions followed this way.
|
||||
(get-metastate (stack-top stack-rest simplify)
|
||||
(let* ((stack (cons stack-top stack-rest))
|
||||
(existing-metastate (gethash stack metastates-hash)))
|
||||
(cond
|
||||
(existing-metastate (values existing-metastate nil))
|
||||
((member stack-top stack-rest :test #'eq)
|
||||
(error "This grammar cannot be represented by a FSM. Stack: ~S" stack))
|
||||
(t (let ((forwarding-production (and simplify (forwarding-state-production stack-top))))
|
||||
(if forwarding-production
|
||||
(let ((stack (apply-reduction-production stack forwarding-production)))
|
||||
(multiple-value-bind (metastate forwarding-productions) (get-metastate (car stack) (cdr stack) simplify)
|
||||
(values metastate (cons forwarding-production forwarding-productions))))
|
||||
(let* ((transitions (make-array n-terminals :initial-element nil))
|
||||
(metastate (make-metastate stack (incf metastate-number) transitions)))
|
||||
(setf (gethash stack metastates-hash) metastate)
|
||||
(push metastate metastates)
|
||||
(dotimes (n n-terminals)
|
||||
(setf (svref transitions n)
|
||||
(get-metatransition stack (svref terminals n) nil)))
|
||||
(values metastate nil)))))))))
|
||||
|
||||
(let ((start-metastate (get-metastate (grammar-start-state grammar) nil nil)))
|
||||
(allocate-metagrammar :grammar grammar
|
||||
:metastates (nreverse metastates)
|
||||
:start start-metastate)))))
|
||||
|
||||
|
||||
; Print the metagrammar nicely.
|
||||
(defun print-metagrammar (metagrammar &optional (stream t) &key (grammar t) (details t))
|
||||
(pprint-logical-block (stream nil)
|
||||
(when grammar
|
||||
(print-grammar (metagrammar-grammar metagrammar) stream :details details))
|
||||
|
||||
;Print the metastates.
|
||||
(format stream "Start metastate: ~@_M~D~:@_~:@_" (metastate-number (metagrammar-start metagrammar)))
|
||||
(pprint-logical-block (stream (metagrammar-metastates metagrammar))
|
||||
(pprint-exit-if-list-exhausted)
|
||||
(format stream "Metastates:~2I~:@_")
|
||||
(loop
|
||||
(print-metastate (pprint-pop) metagrammar stream)
|
||||
(pprint-exit-if-list-exhausted)
|
||||
(pprint-newline :mandatory stream))))
|
||||
(pprint-newline :mandatory stream))
|
||||
|
||||
|
||||
(defmethod print-object ((metagrammar metagrammar) stream)
|
||||
(print-unreadable-object (metagrammar stream :identity t)
|
||||
(write-string "metagrammar" stream)))
|
||||
|
||||
|
||||
; Find the longest possible prefix of the input list of tokens that is accepted by the
|
||||
; grammar. Parse that prefix and return two values:
|
||||
; the list of action results;
|
||||
; the tail of the input list of tokens remaining to be parsed.
|
||||
; Signal an error if no prefix of the input list is accepted by the grammar.
|
||||
;
|
||||
; token-terminal is a function that returns a terminal symbol when given an input token.
|
||||
; If trace is:
|
||||
; nil, don't print trace information
|
||||
; :code, print trace information, including action code
|
||||
; other print trace information
|
||||
(defun action-metaparse (metagrammar token-terminal input &key trace)
|
||||
(if trace
|
||||
(trace-action-metaparse metagrammar token-terminal input trace)
|
||||
(let ((grammar (metagrammar-grammar metagrammar)))
|
||||
(labels
|
||||
((transition-value-stack (value-stack productions)
|
||||
(dolist (production productions)
|
||||
(setq value-stack (funcall (production-evaluator production) value-stack)))
|
||||
value-stack)
|
||||
|
||||
(cut (input good-metastate good-input good-value-stack)
|
||||
(unless good-metastate
|
||||
(error "Parse error on ~S ..." (ldiff input (nthcdr 10 input))))
|
||||
(let ((last-metatransition (metastate-transition good-metastate *end-marker-terminal-number*)))
|
||||
(assert-true (null (metatransition-next-metastate last-metatransition)))
|
||||
(assert-true (null (metatransition-post-productions last-metatransition)))
|
||||
(values
|
||||
(reverse (transition-value-stack good-value-stack (metatransition-pre-productions last-metatransition)))
|
||||
good-input))))
|
||||
|
||||
(do ((metastate (metagrammar-start metagrammar))
|
||||
(input input (cdr input))
|
||||
(value-stack nil)
|
||||
(last-good-metastate nil)
|
||||
last-good-input
|
||||
last-good-value-stack)
|
||||
(nil)
|
||||
(when (metastate-transition metastate *end-marker-terminal-number*)
|
||||
(setq last-good-metastate metastate)
|
||||
(setq last-good-input input)
|
||||
(setq last-good-value-stack value-stack))
|
||||
(when (endp input)
|
||||
(return (cut input last-good-metastate last-good-input last-good-value-stack)))
|
||||
(let* ((token (first input))
|
||||
(terminal (funcall token-terminal token))
|
||||
(terminal-number (terminal-number grammar terminal))
|
||||
(metatransition (metastate-transition metastate terminal-number)))
|
||||
(unless metatransition
|
||||
(return (cut input last-good-metastate last-good-input last-good-value-stack)))
|
||||
(setq value-stack (transition-value-stack value-stack (metatransition-pre-productions metatransition)))
|
||||
(dolist (action-function-binding (gethash terminal (grammar-terminal-actions grammar)))
|
||||
(push (funcall (cdr action-function-binding) token) value-stack))
|
||||
(setq value-stack (transition-value-stack value-stack (metatransition-post-productions metatransition)))
|
||||
(setq metastate (metatransition-next-metastate metatransition))))))))
|
||||
|
||||
|
||||
; Same as action-parse, but with tracing information
|
||||
; If trace is:
|
||||
; :code, print trace information, including action code
|
||||
; other print trace information
|
||||
(defun trace-action-metaparse (metagrammar token-terminal input trace)
|
||||
(let
|
||||
((grammar (metagrammar-grammar metagrammar)))
|
||||
(labels
|
||||
((print-stacks (value-stack type-stack)
|
||||
(write-string " " *trace-output*)
|
||||
(if value-stack
|
||||
(print-values (reverse value-stack) (reverse type-stack) *trace-output*)
|
||||
(write-string "empty" *trace-output*))
|
||||
(pprint-newline :mandatory *trace-output*))
|
||||
|
||||
(transition-value-stack (value-stack type-stack productions)
|
||||
(dolist (production productions)
|
||||
(write-string " reduce " *trace-output*)
|
||||
(if (eq trace :code)
|
||||
(write production :stream *trace-output* :pretty t)
|
||||
(print-production production *trace-output*))
|
||||
(pprint-newline :mandatory *trace-output*)
|
||||
(setq value-stack (funcall (production-evaluator production) value-stack))
|
||||
(setq type-stack (nthcdr (production-n-action-args production) type-stack))
|
||||
(dolist (action-signature (grammar-symbol-signature grammar (production-lhs production)))
|
||||
(push (cdr action-signature) type-stack))
|
||||
(print-stacks value-stack type-stack))
|
||||
(values value-stack type-stack))
|
||||
|
||||
(cut (input good-metastate good-input good-value-stack good-type-stack)
|
||||
(unless good-metastate
|
||||
(error "Parse error on ~S ..." (ldiff input (nthcdr 10 input))))
|
||||
(let ((last-metatransition (metastate-transition good-metastate *end-marker-terminal-number*)))
|
||||
(assert-true (null (metatransition-next-metastate last-metatransition)))
|
||||
(assert-true (null (metatransition-post-productions last-metatransition)))
|
||||
(format *trace-output* "cut to M~D~:@_" (metastate-number good-metastate))
|
||||
(print-stacks good-value-stack good-type-stack)
|
||||
(pprint-newline :mandatory *trace-output*)
|
||||
(values
|
||||
(reverse (transition-value-stack good-value-stack good-type-stack (metatransition-pre-productions last-metatransition)))
|
||||
good-input))))
|
||||
|
||||
(do ((metastate (metagrammar-start metagrammar))
|
||||
(input input (cdr input))
|
||||
(value-stack nil)
|
||||
(type-stack nil)
|
||||
(last-good-metastate nil)
|
||||
last-good-input
|
||||
last-good-value-stack
|
||||
last-good-type-stack)
|
||||
(nil)
|
||||
(format *trace-output* "M~D" (metastate-number metastate))
|
||||
(when (metastate-transition metastate *end-marker-terminal-number*)
|
||||
(write-string " (good)" *trace-output*)
|
||||
(setq last-good-metastate metastate)
|
||||
(setq last-good-input input)
|
||||
(setq last-good-value-stack value-stack)
|
||||
(setq last-good-type-stack type-stack))
|
||||
(write-string ": " *trace-output*)
|
||||
(when (endp input)
|
||||
(return (cut input last-good-metastate last-good-input last-good-value-stack last-good-type-stack)))
|
||||
(let* ((token (first input))
|
||||
(terminal (funcall token-terminal token))
|
||||
(terminal-number (terminal-number grammar terminal))
|
||||
(metatransition (metastate-transition metastate terminal-number)))
|
||||
(unless metatransition
|
||||
(format *trace-output* "shift ~W: " terminal)
|
||||
(return (cut input last-good-metastate last-good-input last-good-value-stack last-good-type-stack)))
|
||||
(format *trace-output* "transition to M~D~:@_" (metastate-number (metatransition-next-metastate metatransition)))
|
||||
(multiple-value-setq (value-stack type-stack)
|
||||
(transition-value-stack value-stack type-stack (metatransition-pre-productions metatransition)))
|
||||
(dolist (action-function-binding (gethash terminal (grammar-terminal-actions grammar)))
|
||||
(push (funcall (cdr action-function-binding) token) value-stack))
|
||||
(dolist (action-signature (grammar-symbol-signature grammar terminal))
|
||||
(push (cdr action-signature) type-stack))
|
||||
(format *trace-output* "shift ~W~:@_" terminal)
|
||||
(print-stacks value-stack type-stack)
|
||||
(multiple-value-setq (value-stack type-stack)
|
||||
(transition-value-stack value-stack type-stack (metatransition-post-productions metatransition)))
|
||||
(setq metastate (metatransition-next-metastate metatransition)))))))
|
||||
|
||||
|
||||
; Compute all representative strings of terminals such that, for each such string S:
|
||||
; S is rejected by the grammar's language;
|
||||
; all prefixes of S are also rejected by the grammar's language;
|
||||
; for any S and all strings of terminals T, the concatenated string ST is also
|
||||
; rejected by the grammar's language;
|
||||
; no string S1 is a prefix of (or equal to) another string S2.
|
||||
; Often there are infinitely many such strings S, so only output one for each illegal
|
||||
; metaparser transition.
|
||||
; Return a list of S's, where each S is itself a list of terminals.
|
||||
(defun compute-illegal-strings (metagrammar)
|
||||
(let* ((grammar (metagrammar-grammar metagrammar))
|
||||
(terminals (grammar-terminals grammar))
|
||||
(n-terminals (length terminals))
|
||||
(metastates (metagrammar-metastates metagrammar))
|
||||
(n-metastates (length metastates))
|
||||
(visited-metastates (make-array n-metastates :element-type 'bit :initial-element 0))
|
||||
(illegal-strings nil))
|
||||
(labels
|
||||
((visit (metastate reversed-string)
|
||||
(let ((metastate-number (metastate-number metastate)))
|
||||
(when (= (sbit visited-metastates metastate-number) 0)
|
||||
(setf (sbit visited-metastates metastate-number) 1)
|
||||
(let ((metatransitions (metastate-transitions metastate)))
|
||||
;If there is a transition for the end marker from this state, then string
|
||||
;is accepted by the language, so cut off the search.
|
||||
(unless (svref metatransitions *end-marker-terminal-number*)
|
||||
(dotimes (terminal-number n-terminals)
|
||||
(unless (= terminal-number *end-marker-terminal-number*)
|
||||
(let ((metatransition (svref metatransitions terminal-number))
|
||||
(reversed-string (cons (svref terminals terminal-number) reversed-string)))
|
||||
(if metatransition
|
||||
(visit (metatransition-next-metastate metatransition) reversed-string)
|
||||
(push (reverse reversed-string) illegal-strings)))))))))))
|
||||
|
||||
(visit (metagrammar-start metagrammar) nil)
|
||||
(nreverse illegal-strings))))
|
||||
|
||||
|
||||
; Compute and print illegal strings of terminals. See compute-illegal-strings.
|
||||
(defun print-illegal-strings (metagrammar &optional (stream t))
|
||||
(pprint-logical-block (stream (compute-illegal-strings metagrammar))
|
||||
(format stream "Illegal strings:~2I")
|
||||
(loop
|
||||
(pprint-exit-if-list-exhausted)
|
||||
(pprint-newline :mandatory stream)
|
||||
(pprint-fill stream (pprint-pop))))
|
||||
(pprint-newline :mandatory stream))
|
||||
|
|
@ -0,0 +1,675 @@
|
|||
;;; The contents of this file are subject to the Netscape Public License
|
||||
;;; Version 1.0 (the "NPL"); you may not use this file except in
|
||||
;;; compliance with the NPL. You may obtain a copy of the NPL at
|
||||
;;; http://www.mozilla.org/NPL/
|
||||
;;;
|
||||
;;; Software distributed under the NPL is distributed on an "AS IS" basis,
|
||||
;;; WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
|
||||
;;; for the specific language governing rights and limitations under the
|
||||
;;; NPL.
|
||||
;;;
|
||||
;;; The Initial Developer of this code under the NPL is Netscape
|
||||
;;; Communications Corporation. Portions created by Netscape are
|
||||
;;; Copyright (C) 1998 Netscape Communications Corporation. All Rights
|
||||
;;; Reserved.
|
||||
|
||||
;;;
|
||||
;;; LALR(1) and LR(1) grammar generator
|
||||
;;;
|
||||
;;; Waldemar Horwat (waldemar@netscape.com)
|
||||
;;;
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
|
||||
; kernel-item-alist is a list of pairs (item . prev), where item is a kernel item
|
||||
; and prev is either nil or a laitem. kernel is a list of the kernel items in a canonical order.
|
||||
; Return a new state with the given list of kernel items and state number.
|
||||
; For each non-null prev in kernel-item-alist, update (laitem-propagates prev) to include the
|
||||
; corresponding laitem in the new state.
|
||||
(defun make-state (grammar kernel kernel-item-alist number initial-lookaheads)
|
||||
(let ((laitems nil)
|
||||
(laitems-hash (make-hash-table :test #'eq)))
|
||||
(labels
|
||||
;Create a laitem for this item and add the association item->laitem to the laitems-hash
|
||||
;hash table if it's not there already. Regardless of whether a new laitem was created,
|
||||
;update the laitem's lookaheads to also include the given lookaheads.
|
||||
;If prev is non-null, update (laitem-propagates prev) to include the laitem if it's not
|
||||
;already included there.
|
||||
;If a new laitem was created and its first symbol after the dot exists and is a
|
||||
;nonterminal A, recursively close items A->.rhs corresponding to all rhs's in the
|
||||
;grammar's rule for A.
|
||||
((close-item (item lookaheads prev)
|
||||
(let ((laitem (gethash item laitems-hash)))
|
||||
(if laitem
|
||||
(setf (laitem-lookaheads laitem)
|
||||
(terminalset-union (laitem-lookaheads laitem) lookaheads))
|
||||
(let ((item-next-symbol (item-next-symbol item)))
|
||||
(setq laitem (allocate-laitem grammar item lookaheads))
|
||||
(push laitem laitems)
|
||||
(setf (gethash item laitems-hash) laitem)
|
||||
(when (nonterminal? item-next-symbol)
|
||||
(multiple-value-bind (next-lookaheads epsilon-lookahead)
|
||||
(string-initial-terminals grammar (rest (item-unseen item)))
|
||||
(let ((next-prev (and epsilon-lookahead laitem)))
|
||||
(dolist (production (rule-productions (grammar-rule grammar item-next-symbol)))
|
||||
(close-item (make-item grammar production 0) next-lookaheads next-prev)))))))
|
||||
(when prev
|
||||
(pushnew laitem (laitem-propagates prev))))))
|
||||
|
||||
(dolist (acons kernel-item-alist nil)
|
||||
(let ((item (car acons))
|
||||
(prev (cdr acons)))
|
||||
(close-item item initial-lookaheads prev)))
|
||||
(allocate-state number kernel (nreverse laitems)))))
|
||||
|
||||
|
||||
; f is a function that takes two arguments:
|
||||
; a grammar symbol, and
|
||||
; a list of kernel items in order of increasing item number.
|
||||
; a list of pairs (item . prev), where item is a kernel item and prev is a laitem;
|
||||
; For each possible symbol X that can be shifted while in the given state S, call
|
||||
; f giving it S and the list of items that constitute the kernel of that shift's destination
|
||||
; state. The prev's are the sources of the corresponding shifted items.
|
||||
(defun state-each-shift-item-alist (f state)
|
||||
(let ((shift-symbols-hash (make-hash-table :test *grammar-symbol-=*)))
|
||||
(dolist (source-laitem (state-laitems state))
|
||||
(let* ((source-item (laitem-item source-laitem))
|
||||
(shift-symbol (item-next-symbol source-item)))
|
||||
(when shift-symbol
|
||||
(push (cons (item-next source-item) source-laitem)
|
||||
(gethash shift-symbol shift-symbols-hash)))))
|
||||
;Use dolist/gethash instead of maphash to make state assignments deterministic.
|
||||
(dolist (shift-symbol (sorted-hash-table-keys shift-symbols-hash))
|
||||
(let ((kernel-item-alist (gethash shift-symbol shift-symbols-hash)))
|
||||
(funcall f shift-symbol (sort (mapcar #'car kernel-item-alist) #'< :key #'item-number) kernel-item-alist)))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; LR(1)
|
||||
|
||||
|
||||
; kernel-item-alist should have the same kernel items as state.
|
||||
; Return true if the prev lookaheads in kernel-item-alist are the same as or subsets of
|
||||
; the corresponding lookaheads in the state's kernel laitems.
|
||||
(defun state-subsumes-lookaheads (state kernel-item-alist)
|
||||
(every
|
||||
#'(lambda (acons)
|
||||
(terminalset-<= (laitem-lookaheads (cdr acons))
|
||||
(laitem-lookaheads (state-laitem state (car acons)))))
|
||||
kernel-item-alist))
|
||||
|
||||
|
||||
; kernel-item-alist should have the same kernel items as state.
|
||||
; Return true if the prev lookaheads in kernel-item-alist are weakly compatible
|
||||
; with the lookaheads in the state's kernel laitems.
|
||||
(defun state-weakly-compatible (state kernel-item-alist)
|
||||
(labels
|
||||
((lookahead-weakly-compatible (lookahead1a lookahead1b lookahead2a lookahead2b)
|
||||
(or (and (terminalsets-disjoint lookahead1a lookahead2b)
|
||||
(terminalsets-disjoint lookahead1b lookahead2a))
|
||||
(not (terminalsets-disjoint lookahead1a lookahead1b))
|
||||
(not (terminalsets-disjoint lookahead2a lookahead2b))))
|
||||
|
||||
(lookahead-list-weakly-compatible (lookahead1a lookaheads1 lookahead2a lookaheads2)
|
||||
(or (endp lookaheads1)
|
||||
(and (lookahead-weakly-compatible lookahead1a (first lookaheads1) lookahead2a (first lookaheads2))
|
||||
(lookahead-list-weakly-compatible lookahead1a (rest lookaheads1) lookahead2a (rest lookaheads2)))))
|
||||
|
||||
(lookahead-lists-weakly-compatible (lookaheads1 lookaheads2)
|
||||
(or (endp lookaheads1)
|
||||
(and (lookahead-list-weakly-compatible (first lookaheads1) (rest lookaheads1) (first lookaheads2) (rest lookaheads2))
|
||||
(lookahead-lists-weakly-compatible (rest lookaheads1) (rest lookaheads2))))))
|
||||
|
||||
(or (= (length kernel-item-alist) 1)
|
||||
(lookahead-lists-weakly-compatible
|
||||
(mapcar #'(lambda (acons) (laitem-lookaheads (state-laitem state (car acons)))) kernel-item-alist)
|
||||
(mapcar #'(lambda (acons) (laitem-lookaheads (cdr acons))) kernel-item-alist)))))
|
||||
|
||||
|
||||
; Propagate all lookaheads in the state.
|
||||
(defun propagate-internal-lookaheads (state)
|
||||
(dolist (src-laitem (state-laitems state))
|
||||
(let ((src-lookaheads (laitem-lookaheads src-laitem)))
|
||||
(dolist (dst-laitem (laitem-propagates src-laitem))
|
||||
(setf (laitem-lookaheads dst-laitem)
|
||||
(terminalset-union (laitem-lookaheads dst-laitem) src-lookaheads))))))
|
||||
|
||||
|
||||
; Propagate all lookaheads in kernel-item-alist, which must target destination-state.
|
||||
; Mark destination-state as dirty in the dirty-states hash table.
|
||||
(defun propagate-external-lookaheads (kernel-item-alist destination-state dirty-states)
|
||||
(dolist (acons kernel-item-alist)
|
||||
(let ((dest-laitem (state-laitem destination-state (car acons)))
|
||||
(src-laitem (cdr acons)))
|
||||
(setf (laitem-lookaheads dest-laitem)
|
||||
(terminalset-union (laitem-lookaheads dest-laitem) (laitem-lookaheads src-laitem)))))
|
||||
(setf (gethash destination-state dirty-states) t))
|
||||
|
||||
|
||||
; Make all states in the grammar and return the initial state.
|
||||
; Initialize the grammar's list of states.
|
||||
; Set up the laitems' propagate lists but do not propagate lookaheads yet.
|
||||
; Initialize the states' gotos lists.
|
||||
; Initialize the states' shift (but not reduce or accept) transitions in the transitions lists.
|
||||
(defun add-all-lr-states (grammar)
|
||||
(let* ((initial-item (make-item grammar (grammar-start-production grammar) 0))
|
||||
(lr-states-hash (make-hash-table :test #'equal)) ;kernel -> list of states with that kernel
|
||||
(initial-kernel (list initial-item))
|
||||
(initial-state (make-state grammar initial-kernel (list (cons initial-item nil)) 0 (make-terminalset grammar *end-marker*)))
|
||||
(states (list initial-state))
|
||||
(next-state-number 1))
|
||||
(setf (gethash initial-kernel lr-states-hash) (list initial-state))
|
||||
(do ((source-states (list initial-state))
|
||||
(dirty-states (make-hash-table :test #'eq))) ;Set of states whose kernel lookaheads changed and haven't been propagated yet
|
||||
((and (endp source-states) (zerop (hash-table-count dirty-states))))
|
||||
(labels
|
||||
((make-destination-state (kernel kernel-item-alist)
|
||||
(let* ((possible-destination-states (gethash kernel lr-states-hash))
|
||||
(destination-state (find-if #'(lambda (possible-destination-state)
|
||||
(state-subsumes-lookaheads possible-destination-state kernel-item-alist))
|
||||
possible-destination-states)))
|
||||
(cond
|
||||
(destination-state)
|
||||
((setq destination-state (find-if #'(lambda (possible-destination-state)
|
||||
(state-weakly-compatible possible-destination-state kernel-item-alist))
|
||||
possible-destination-states))
|
||||
(propagate-external-lookaheads kernel-item-alist destination-state dirty-states))
|
||||
(t
|
||||
(setq destination-state (make-state grammar kernel kernel-item-alist next-state-number *empty-terminalset*))
|
||||
(propagate-external-lookaheads kernel-item-alist destination-state dirty-states)
|
||||
(push destination-state (gethash kernel lr-states-hash))
|
||||
(incf next-state-number)
|
||||
(push destination-state states)
|
||||
(push destination-state source-states)))
|
||||
destination-state))
|
||||
|
||||
(update-destination-state (destination-state kernel-item-alist)
|
||||
(cond
|
||||
((state-subsumes-lookaheads destination-state kernel-item-alist)
|
||||
destination-state)
|
||||
((state-weakly-compatible destination-state kernel-item-alist)
|
||||
(propagate-external-lookaheads kernel-item-alist destination-state dirty-states)
|
||||
destination-state)
|
||||
(t (make-destination-state (state-kernel destination-state) kernel-item-alist)))))
|
||||
|
||||
(if source-states
|
||||
(let ((source-state (pop source-states)))
|
||||
(remhash source-state dirty-states)
|
||||
(propagate-internal-lookaheads source-state)
|
||||
(state-each-shift-item-alist
|
||||
#'(lambda (shift-symbol kernel kernel-item-alist)
|
||||
(let ((destination-state (make-destination-state kernel kernel-item-alist)))
|
||||
(if (nonterminal? shift-symbol)
|
||||
(push (cons shift-symbol destination-state)
|
||||
(state-gotos source-state))
|
||||
(push (cons shift-symbol (make-shift-transition destination-state))
|
||||
(state-transitions source-state)))))
|
||||
source-state))
|
||||
(dolist (dirty-state (sort (hash-table-keys dirty-states) #'< :key #'state-number))
|
||||
(when (remhash dirty-state dirty-states)
|
||||
(propagate-internal-lookaheads dirty-state)
|
||||
(state-each-shift-item-alist
|
||||
#'(lambda (shift-symbol kernel kernel-item-alist)
|
||||
(declare (ignore kernel))
|
||||
(if (nonterminal? shift-symbol)
|
||||
(let* ((destination-binding (assoc shift-symbol (state-gotos dirty-state) :test *grammar-symbol-=*))
|
||||
(destination-state (assert-non-null (cdr destination-binding))))
|
||||
(setf (cdr destination-binding) (update-destination-state destination-state kernel-item-alist)))
|
||||
(let* ((destination-transition (cdr (assoc shift-symbol (state-transitions dirty-state) :test *grammar-symbol-=*)))
|
||||
(destination-state (assert-non-null (transition-state destination-transition))))
|
||||
(setf (transition-state destination-transition)
|
||||
(update-destination-state destination-state kernel-item-alist)))))
|
||||
dirty-state))))))
|
||||
(setf (grammar-states grammar) (nreverse states))
|
||||
initial-state))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; LALR(1)
|
||||
|
||||
|
||||
; Make all states in the grammar and return the initial state.
|
||||
; Initialize the grammar's list of states.
|
||||
; Set up the laitems' propagate lists but do not propagate lookaheads yet.
|
||||
; Initialize the states' gotos lists.
|
||||
; Initialize the states' shift (but not reduce or accept) transitions in the transitions lists.
|
||||
(defun add-all-lalr-states (grammar)
|
||||
(let* ((initial-item (make-item grammar (grammar-start-production grammar) 0))
|
||||
(lalr-states-hash (make-hash-table :test #'equal)) ;kernel -> state
|
||||
(initial-kernel (list initial-item))
|
||||
(initial-state (make-state grammar initial-kernel (list (cons initial-item nil)) 0 (make-terminalset grammar *end-marker*)))
|
||||
(states (list initial-state))
|
||||
(next-state-number 1))
|
||||
(setf (gethash initial-kernel lalr-states-hash) initial-state)
|
||||
(do ((source-states (list initial-state)))
|
||||
((endp source-states))
|
||||
(let ((source-state (pop source-states)))
|
||||
(state-each-shift-item-alist
|
||||
#'(lambda (shift-symbol kernel kernel-item-alist)
|
||||
(let ((destination-state (gethash kernel lalr-states-hash)))
|
||||
(if destination-state
|
||||
(dolist (acons kernel-item-alist)
|
||||
(pushnew (state-laitem destination-state (car acons)) (laitem-propagates (cdr acons))))
|
||||
(progn
|
||||
(setq destination-state (make-state grammar kernel kernel-item-alist next-state-number *empty-terminalset*))
|
||||
(setf (gethash kernel lalr-states-hash) destination-state)
|
||||
(incf next-state-number)
|
||||
(push destination-state states)
|
||||
(push destination-state source-states)))
|
||||
(if (nonterminal? shift-symbol)
|
||||
(push (cons shift-symbol destination-state)
|
||||
(state-gotos source-state))
|
||||
(push (cons shift-symbol (make-shift-transition destination-state))
|
||||
(state-transitions source-state)))))
|
||||
source-state)))
|
||||
(setf (grammar-states grammar) (nreverse states))
|
||||
initial-state))
|
||||
|
||||
|
||||
; Propagate the lookaheads in the LALR(1) grammar.
|
||||
(defun propagate-lalr-lookaheads (grammar)
|
||||
(let ((dirty-laitems (make-hash-table :test #'eq)))
|
||||
(dolist (state (grammar-states grammar))
|
||||
(dolist (laitem (state-laitems state))
|
||||
(when (and (laitem-propagates laitem) (not (terminalset-empty? (laitem-lookaheads laitem))))
|
||||
(setf (gethash laitem dirty-laitems) t))))
|
||||
(do ()
|
||||
((zerop (hash-table-count dirty-laitems)))
|
||||
(dolist (dirty-laitem (hash-table-keys dirty-laitems))
|
||||
(remhash dirty-laitem dirty-laitems)
|
||||
(let ((src-lookaheads (laitem-lookaheads dirty-laitem)))
|
||||
(dolist (dst-laitem (laitem-propagates dirty-laitem))
|
||||
(let* ((old-dst-lookaheads (laitem-lookaheads dst-laitem))
|
||||
(new-dst-lookaheads (terminalset-union old-dst-lookaheads src-lookaheads)))
|
||||
(unless (terminalset-= old-dst-lookaheads new-dst-lookaheads)
|
||||
(setf (laitem-lookaheads dst-laitem) new-dst-lookaheads)
|
||||
(setf (gethash dst-laitem dirty-laitems) t)))))))
|
||||
|
||||
;Erase the propagates chains in all laitems.
|
||||
(dolist (state (grammar-states grammar))
|
||||
(dolist (laitem (state-laitems state))
|
||||
(setf (laitem-propagates laitem) nil)))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
|
||||
|
||||
; Calculate the reduce and accept transitions in the grammar.
|
||||
; Also sort all transitions by their terminal numbers and gotos by their nonterminal numbers.
|
||||
; Conflicting transitions are sorted as follows:
|
||||
; shifts come before reduces and accepts
|
||||
; accepts come before reduces
|
||||
; reduces with lower production numbers come before reduces with higher production numbers
|
||||
; Disambiguation will choose the first member of a sorted list of conflicting transitions.
|
||||
(defun finish-transitions (grammar)
|
||||
(dolist (state (grammar-states grammar))
|
||||
(dolist (laitem (state-laitems state))
|
||||
(let ((item (laitem-item laitem)))
|
||||
(unless (item-next-symbol item)
|
||||
(if (grammar-symbol-= (item-lhs item) *start-nonterminal*)
|
||||
(when (terminal-in-terminalset grammar *end-marker* (laitem-lookaheads laitem))
|
||||
(push (cons *end-marker* (make-accept-transition))
|
||||
(state-transitions state)))
|
||||
(map-terminalset-reverse
|
||||
#'(lambda (lookahead)
|
||||
(push (cons lookahead (make-reduce-transition (item-production item)))
|
||||
(state-transitions state)))
|
||||
grammar
|
||||
(laitem-lookaheads laitem))))))
|
||||
(setf (state-gotos state)
|
||||
(sort (state-gotos state) #'< :key #'(lambda (goto-cons) (state-number (cdr goto-cons)))))
|
||||
(setf (state-transitions state)
|
||||
(sort (state-transitions state)
|
||||
#'(lambda (transition-cons-1 transition-cons-2)
|
||||
(let ((terminal-number-1 (terminal-number grammar (car transition-cons-1)))
|
||||
(terminal-number-2 (terminal-number grammar (car transition-cons-2))))
|
||||
(cond
|
||||
((< terminal-number-1 terminal-number-2) t)
|
||||
((> terminal-number-1 terminal-number-2) nil)
|
||||
(t (let* ((transition1 (cdr transition-cons-1))
|
||||
(transition2 (cdr transition-cons-2))
|
||||
(transition-kind-1 (transition-kind transition1))
|
||||
(transition-kind-2 (transition-kind transition2)))
|
||||
(cond
|
||||
((eq transition-kind-2 :shift) nil)
|
||||
((eq transition-kind-1 :shift) t)
|
||||
((eq transition-kind-2 :accept) nil)
|
||||
((eq transition-kind-1 :accept) t)
|
||||
(t (let ((production-number-1 (production-number (transition-production transition1)))
|
||||
(production-number-2 (production-number (transition-production transition2))))
|
||||
(< production-number-1 production-number-2)))))))))))))
|
||||
|
||||
|
||||
; Find ambiguities, if any, in the grammar. Report them on the given stream.
|
||||
; Fix all ambiguities in favor of the first transition listed
|
||||
; (the transitions were ordered by finish-transitions).
|
||||
(defun report-and-fix-ambiguities (grammar stream)
|
||||
(let ((found-ambiguities nil))
|
||||
(pprint-logical-block (stream nil)
|
||||
(dolist (state (grammar-states grammar))
|
||||
(labels
|
||||
|
||||
((report-ambiguity (transition-cons other-transition-conses)
|
||||
(unless found-ambiguities
|
||||
(setq found-ambiguities t)
|
||||
(format stream "~&Ambiguities:")
|
||||
(pprint-indent :block 2 stream))
|
||||
(pprint-newline :mandatory stream)
|
||||
(pprint-logical-block (stream nil)
|
||||
(format stream "S~D: ~W ~:_=> ~:_" (state-number state) (car transition-cons))
|
||||
(pprint-logical-block (stream nil)
|
||||
(dolist (a (cons transition-cons other-transition-conses))
|
||||
(print-transition (cdr a) stream)
|
||||
(format stream " ~:_")))))
|
||||
|
||||
; Check the list of transition-conses and report ambiguities.
|
||||
; start is the start of a possibly larger list of transition-conses whose tail
|
||||
; is the given list. If ambiguities exist, return a copy of start up to the
|
||||
; position of list in it followed by list with ambiguities removed. If not,
|
||||
; return start unchanged.
|
||||
(check (transition-conses start)
|
||||
(if transition-conses
|
||||
(let* ((transition-cons (first transition-conses))
|
||||
(transition-terminal (car transition-cons))
|
||||
(transition-conses-rest (rest transition-conses)))
|
||||
(if transition-conses-rest
|
||||
(if (grammar-symbol-= transition-terminal (car (first transition-conses-rest)))
|
||||
(let ((unrelated-transitions
|
||||
(member-if #'(lambda (a) (not (grammar-symbol-= transition-terminal (car a))))
|
||||
transition-conses-rest)))
|
||||
(report-ambiguity transition-cons (ldiff transition-conses-rest unrelated-transitions))
|
||||
(check unrelated-transitions (append (ldiff start transition-conses-rest) unrelated-transitions)))
|
||||
(check transition-conses-rest start))
|
||||
start))
|
||||
start)))
|
||||
|
||||
(let ((transition-conses (state-transitions state)))
|
||||
(setf (state-transitions state) (check transition-conses transition-conses))))))
|
||||
(when found-ambiguities
|
||||
(pprint-newline :mandatory stream))))
|
||||
|
||||
|
||||
; Erase the existing parser, if any, for the given grammar.
|
||||
(defun clear-parser (grammar)
|
||||
(clrhash (grammar-items-hash grammar))
|
||||
(setf (grammar-states grammar) nil))
|
||||
|
||||
|
||||
; Construct a LR or LALR parser in the given grammar. kind should be either :lalr-1 or :lr-1.
|
||||
; Return the grammar.
|
||||
(defun compile-parser (grammar kind)
|
||||
(clear-parser grammar)
|
||||
(ecase kind
|
||||
(:lalr-1
|
||||
(add-all-lalr-states grammar)
|
||||
(propagate-lalr-lookaheads grammar))
|
||||
(:lr-1
|
||||
(add-all-lr-states grammar)))
|
||||
(finish-transitions grammar)
|
||||
(report-and-fix-ambiguities grammar *error-output*)
|
||||
grammar)
|
||||
|
||||
|
||||
; Make the grammar and compile its parser. kind should be either :lalr-1 or :lr-1.
|
||||
(defun make-and-compile-grammar (kind parametrization start-symbol grammar-source)
|
||||
(compile-parser (make-grammar parametrization start-symbol grammar-source)
|
||||
kind))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
|
||||
; Parse the input list of tokens to produce a parse tree.
|
||||
; token-terminal is a function that returns a terminal symbol when given an input token.
|
||||
(defun parse (grammar token-terminal input)
|
||||
(labels
|
||||
(;Continue the parse with the given parser stack and remainder of input.
|
||||
(parse-step (stack input)
|
||||
(if (endp input)
|
||||
(parse-step-1 stack *end-marker* nil nil)
|
||||
(let ((token (first input)))
|
||||
(parse-step-1 stack (funcall token-terminal token) token (rest input)))))
|
||||
|
||||
;Same as parse-step except that the next input terminal has been determined already.
|
||||
;input-rest contains the input tokens after the next token.
|
||||
(parse-step-1 (stack terminal token input-rest)
|
||||
(let* ((state (caar stack))
|
||||
(transition (cdr (assoc terminal (state-transitions state) :test *grammar-symbol-=*))))
|
||||
(if transition
|
||||
(case (transition-kind transition)
|
||||
(:shift (parse-step (acons (transition-state transition) token stack) input-rest))
|
||||
(:reduce (let ((production (transition-production transition))
|
||||
(expansion nil))
|
||||
(dotimes (i (production-rhs-length production))
|
||||
(push (cdr (pop stack)) expansion))
|
||||
(let* ((state (caar stack))
|
||||
(dst-state (assert-non-null
|
||||
(cdr (assoc (production-lhs production) (state-gotos state) :test *grammar-symbol-=*))))
|
||||
(named-expansion (cons (production-name production) expansion)))
|
||||
(parse-step-1 (acons dst-state named-expansion stack) terminal token input-rest))))
|
||||
(:accept (cdar stack))
|
||||
(t (error "Bad transition: ~S" transition)))
|
||||
(error "Parse error on ~S followed by ~S ..." token (ldiff input-rest (nthcdr 10 input-rest)))))))
|
||||
|
||||
(parse-step (list (cons (grammar-start-state grammar) nil)) input)))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; ACTIONS
|
||||
|
||||
; Initialize the action-signatures hash table, setting each grammar symbol's signature
|
||||
; to null for now. Also clear all production actions in the grammar.
|
||||
(defun clear-actions (grammar)
|
||||
(let ((action-signatures (make-hash-table :test *grammar-symbol-=*))
|
||||
(terminals (grammar-terminals grammar))
|
||||
(nonterminals (grammar-nonterminals grammar)))
|
||||
(dotimes (i (length terminals))
|
||||
(setf (gethash (svref terminals i) action-signatures) nil))
|
||||
(dotimes (i (length nonterminals))
|
||||
(setf (gethash (svref nonterminals i) action-signatures) nil))
|
||||
(setf (grammar-action-signatures grammar) action-signatures)
|
||||
(each-grammar-production
|
||||
grammar
|
||||
#'(lambda (production)
|
||||
(setf (production-actions production) nil)
|
||||
(setf (production-n-action-args production) nil)
|
||||
(setf (production-evaluator-code production) nil)
|
||||
(setf (production-evaluator production) nil)))
|
||||
(clrhash (grammar-terminal-actions grammar))))
|
||||
|
||||
|
||||
; Declare the type of action action-symbol, when called on general-grammar-symbol, to be type-expr.
|
||||
; Signal an error on duplicate actions.
|
||||
; It's OK if some of the symbol instances don't exist, as long as at least one does.
|
||||
(defun declare-action (grammar general-grammar-symbol action-symbol type-expr)
|
||||
(unless (and action-symbol (symbolp action-symbol))
|
||||
(error "Bad action name ~S" action-symbol))
|
||||
(let ((action-signatures (grammar-action-signatures grammar))
|
||||
(grammar-symbols (general-grammar-symbol-instances grammar general-grammar-symbol))
|
||||
(symbol-exists nil))
|
||||
(dolist (grammar-symbol grammar-symbols)
|
||||
(let ((signature (gethash grammar-symbol action-signatures :undefined)))
|
||||
(unless (eq signature :undefined)
|
||||
(setq symbol-exists t)
|
||||
(when (assoc action-symbol signature :test #'eq)
|
||||
(error "Attempt to redefine the type of action ~S on ~S" action-symbol grammar-symbol))
|
||||
(setf (gethash grammar-symbol action-signatures)
|
||||
(nconc signature (list (cons action-symbol type-expr))))
|
||||
(if (nonterminal? grammar-symbol)
|
||||
(dolist (production (rule-productions (grammar-rule grammar grammar-symbol)))
|
||||
(setf (production-actions production)
|
||||
(nconc (production-actions production) (list (cons action-symbol nil)))))
|
||||
(let ((terminal-actions (grammar-terminal-actions grammar)))
|
||||
(assert-type grammar-symbol terminal)
|
||||
(setf (gethash grammar-symbol terminal-actions)
|
||||
(nconc (gethash grammar-symbol terminal-actions) (list (cons action-symbol nil)))))))))
|
||||
(unless symbol-exists
|
||||
(error "Bad action grammar symbol ~S" grammar-symbols))))
|
||||
|
||||
|
||||
; Return the list of pairs (action-symbol . type-or-type-expr) for this grammar-symbol.
|
||||
; The pairs are in order from oldest to newest action-symbols added to this grammar-symbol.
|
||||
(declaim (inline grammar-symbol-signature))
|
||||
(defun grammar-symbol-signature (grammar grammar-symbol)
|
||||
(gethash grammar-symbol (grammar-action-signatures grammar)))
|
||||
|
||||
|
||||
; Return the list of action types of the grammar's user start-symbol.
|
||||
(defun grammar-user-start-action-types (grammar)
|
||||
(mapcar #'cdr (grammar-symbol-signature grammar (gramar-user-start-symbol grammar))))
|
||||
|
||||
|
||||
; If action action-symbol is declared on grammar-symbol, return two values:
|
||||
; t, and
|
||||
; the action's type-expr;
|
||||
; If not, return nil.
|
||||
(defun action-declaration (grammar grammar-symbol action-symbol)
|
||||
(let ((declaration (assoc action-symbol (grammar-symbol-signature grammar grammar-symbol) :test #'eq)))
|
||||
(and declaration
|
||||
(values t (cdr declaration)))))
|
||||
|
||||
|
||||
; Call f on every action declaration, passing it two arguments:
|
||||
; the grammar-symbol;
|
||||
; a pair (action-symbol . type-expr).
|
||||
; f may modify the action's type-expr.
|
||||
(defun each-action-declaration (grammar f)
|
||||
(maphash #'(lambda (grammar-symbol signature)
|
||||
(dolist (action-declaration signature)
|
||||
(funcall f grammar-symbol action-declaration)))
|
||||
(grammar-action-signatures grammar)))
|
||||
|
||||
|
||||
; Define action action-symbol, when called on the production with the given name,
|
||||
; to be action-expr. The action should have been declared already.
|
||||
(defun define-action (grammar production-name action-symbol action-expr)
|
||||
(dolist (production (general-production-productions (grammar-general-production grammar production-name)))
|
||||
(let ((definition (assoc action-symbol (production-actions production) :test #'eq)))
|
||||
(cond
|
||||
((null definition)
|
||||
(error "Attempt to define action ~S on ~S, which hasn't been declared yet" action-symbol production-name))
|
||||
((cdr definition)
|
||||
(error "Duplicate definition of action ~S on ~S" action-symbol production-name))
|
||||
(t (setf (cdr definition) (make-action action-expr)))))))
|
||||
|
||||
|
||||
; Define action action-symbol, when called on the given terminal,
|
||||
; to execute the given function, which should take a token as an input and
|
||||
; produce a value of the proper type as output.
|
||||
; The action should have been declared already.
|
||||
(defun define-terminal-action (grammar terminal action-symbol action-function)
|
||||
(assert-type action-function function)
|
||||
(let ((definition (assoc action-symbol (gethash terminal (grammar-terminal-actions grammar)) :test #'eq)))
|
||||
(cond
|
||||
((null definition)
|
||||
(error "Attempt to define action ~S on ~S, which hasn't been declared yet" action-symbol terminal))
|
||||
((cdr definition)
|
||||
(error "Duplicate definition of action ~S on ~S" action-symbol terminal))
|
||||
(t (setf (cdr definition) action-function)))))
|
||||
|
||||
|
||||
|
||||
; Parse the input list of tokens to produce a list of action results.
|
||||
; token-terminal is a function that returns a terminal symbol when given an input token.
|
||||
; If trace is:
|
||||
; nil, don't print trace information
|
||||
; :code, print trace information, including action code
|
||||
; other print trace information
|
||||
; Return two values:
|
||||
; the list of action results;
|
||||
; the list of action results' types.
|
||||
(defun action-parse (grammar token-terminal input &key trace)
|
||||
(labels
|
||||
(;Continue the parse with the given stacks and remainder of input.
|
||||
(parse-step (state-stack value-stack input)
|
||||
(if (endp input)
|
||||
(parse-step-1 state-stack value-stack *end-marker* nil nil)
|
||||
(let ((token (first input)))
|
||||
(parse-step-1 state-stack value-stack (funcall token-terminal token) token (rest input)))))
|
||||
|
||||
;Same as parse-step except that the next input terminal has been determined already.
|
||||
;input-rest contains the input tokens after the next token.
|
||||
(parse-step-1 (state-stack value-stack terminal token input-rest)
|
||||
(let* ((state (car state-stack))
|
||||
(transition (cdr (assoc terminal (state-transitions state) :test *grammar-symbol-=*))))
|
||||
(if transition
|
||||
(case (transition-kind transition)
|
||||
(:shift
|
||||
(dolist (action-function-binding (gethash terminal (grammar-terminal-actions grammar)))
|
||||
(push (funcall (cdr action-function-binding) token) value-stack))
|
||||
(parse-step (cons (transition-state transition) state-stack) value-stack input-rest))
|
||||
(:reduce
|
||||
(let* ((production (transition-production transition))
|
||||
(state-stack (nthcdr (production-rhs-length production) state-stack))
|
||||
(state (car state-stack))
|
||||
(dst-state (assert-non-null
|
||||
(cdr (assoc (production-lhs production) (state-gotos state) :test *grammar-symbol-=*))))
|
||||
(value-stack (funcall (production-evaluator production) value-stack)))
|
||||
(parse-step-1 (cons dst-state state-stack) value-stack terminal token input-rest)))
|
||||
(:accept (values (nreverse value-stack) (grammar-user-start-action-types grammar)))
|
||||
(t (error "Bad transition: ~S" transition)))
|
||||
(error "Parse error on ~S followed by ~S ..." token (ldiff input-rest (nthcdr 10 input-rest)))))))
|
||||
|
||||
(if trace
|
||||
(trace-action-parse grammar token-terminal input trace)
|
||||
(parse-step (list (grammar-start-state grammar)) nil input))))
|
||||
|
||||
|
||||
; Same as action-parse, but with tracing information
|
||||
; If trace is:
|
||||
; :code, print trace information, including action code
|
||||
; other print trace information
|
||||
; Return two values:
|
||||
; the list of action results;
|
||||
; the list of action results' types.
|
||||
(defun trace-action-parse (grammar token-terminal input trace)
|
||||
(labels
|
||||
(;Continue the parse with the given stacks and remainder of input.
|
||||
;type-stack contains the types of corresponding value-stack entries.
|
||||
(parse-step (state-stack value-stack type-stack input)
|
||||
(if (endp input)
|
||||
(parse-step-1 state-stack value-stack type-stack *end-marker* nil nil)
|
||||
(let ((token (first input)))
|
||||
(parse-step-1 state-stack value-stack type-stack (funcall token-terminal token) token (rest input)))))
|
||||
|
||||
;Same as parse-step except that the next input terminal has been determined already.
|
||||
;input-rest contains the input tokens after the next token.
|
||||
(parse-step-1 (state-stack value-stack type-stack terminal token input-rest)
|
||||
(let* ((state (car state-stack))
|
||||
(transition (cdr (assoc terminal (state-transitions state) :test *grammar-symbol-=*))))
|
||||
(format *trace-output* "S~D: ~@_" (state-number state))
|
||||
(print-values (reverse value-stack) (reverse type-stack) *trace-output*)
|
||||
(pprint-newline :mandatory *trace-output*)
|
||||
(if transition
|
||||
(case (transition-kind transition)
|
||||
(:shift
|
||||
(format *trace-output* " shift ~W~:@_" terminal)
|
||||
(dolist (action-function-binding (gethash terminal (grammar-terminal-actions grammar)))
|
||||
(push (funcall (cdr action-function-binding) token) value-stack))
|
||||
(dolist (action-signature (grammar-symbol-signature grammar terminal))
|
||||
(push (cdr action-signature) type-stack))
|
||||
(parse-step (cons (transition-state transition) state-stack) value-stack type-stack input-rest))
|
||||
(:reduce
|
||||
(let ((production (transition-production transition)))
|
||||
(write-string " reduce " *trace-output*)
|
||||
(if (eq trace :code)
|
||||
(write production :stream *trace-output* :pretty t)
|
||||
(print-production production *trace-output*))
|
||||
(pprint-newline :mandatory *trace-output*)
|
||||
(let* ((state-stack (nthcdr (production-rhs-length production) state-stack))
|
||||
(state (car state-stack))
|
||||
(dst-state (assert-non-null
|
||||
(cdr (assoc (production-lhs production) (state-gotos state) :test *grammar-symbol-=*))))
|
||||
(value-stack (funcall (production-evaluator production) value-stack))
|
||||
(type-stack (nthcdr (production-n-action-args production) type-stack)))
|
||||
(dolist (action-signature (grammar-symbol-signature grammar (production-lhs production)))
|
||||
(push (cdr action-signature) type-stack))
|
||||
(parse-step-1 (cons dst-state state-stack) value-stack type-stack terminal token input-rest))))
|
||||
(:accept
|
||||
(format *trace-output* " accept~:@_")
|
||||
(values (nreverse value-stack) (nreverse type-stack)))
|
||||
(t (error "Bad transition: ~S" transition)))
|
||||
(error "Parse error on ~S followed by ~S ..." token (ldiff input-rest (nthcdr 10 input-rest)))))))
|
||||
|
||||
(parse-step (list (grammar-start-state grammar)) nil nil input)))
|
||||
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
js/semantics contains experimental code used to generate LR(1) and LALR(1)
|
||||
grammars for JavaScript as well as compile and check formal semantics for
|
||||
JavaScript. The semantics can be executed directly or printed into either
|
||||
HTML or Microsoft Word RTF formats.
|
||||
|
||||
This code is written in standard Common Lisp. It's been used under Macintosh
|
||||
Common Lisp 4.0, but should also work under other Common Lisp implementations.
|
||||
|
||||
Contact Waldemar Horwat (waldemar@netscape.com or waldemar@acm.org) for
|
||||
more information.
|
||||
|
|
@ -0,0 +1,699 @@
|
|||
;;; The contents of this file are subject to the Netscape Public License
|
||||
;;; Version 1.0 (the "NPL"); you may not use this file except in
|
||||
;;; compliance with the NPL. You may obtain a copy of the NPL at
|
||||
;;; http://www.mozilla.org/NPL/
|
||||
;;;
|
||||
;;; Software distributed under the NPL is distributed on an "AS IS" basis,
|
||||
;;; WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
|
||||
;;; for the specific language governing rights and limitations under the
|
||||
;;; NPL.
|
||||
;;;
|
||||
;;; The Initial Developer of this code under the NPL is Netscape
|
||||
;;; Communications Corporation. Portions created by Netscape are
|
||||
;;; Copyright (C) 1998 Netscape Communications Corporation. All Rights
|
||||
;;; Reserved.
|
||||
|
||||
;;;
|
||||
;;; RTF reader and writer
|
||||
;;;
|
||||
;;; Waldemar Horwat (waldemar@netscape.com)
|
||||
;;;
|
||||
|
||||
|
||||
;;; 1440 twips/inch
|
||||
;;; 20 twips/pt
|
||||
|
||||
(defparameter *rtf-definitions*
|
||||
'((:rtf-intro rtf 1 mac ansicpg 10000 uc 1 deff 0 deflang 2057 deflangfe 2057)
|
||||
|
||||
;Fonts
|
||||
((+ :rtf-intro) :fonttbl)
|
||||
(:fonttbl (fonttbl :fonts))
|
||||
|
||||
(:times f 0)
|
||||
((+ :fonts) (:times froman fcharset 256 fprq 2 (* panose "02020603050405020304") "Times New Roman;"))
|
||||
(:symbol f 3)
|
||||
((+ :fonts) (:symbol ftech fcharset 2 fprq 2 "Symbol;"))
|
||||
(:helvetica f 4)
|
||||
((+ :fonts) (:helvetica fnil fcharset 256 fprq 2 "Helvetica;"))
|
||||
(:courier f 5)
|
||||
((+ :fonts) (:courier fmodern fcharset 256 fprq 2 "Courier New;"))
|
||||
(:palatino f 6)
|
||||
((+ :fonts) (:palatino fnil fcharset 256 fprq 2 "Palatino;"))
|
||||
(:zapf-chancery f 7)
|
||||
((+ :fonts) (:zapf-chancery fscript fcharset 256 fprq 2 "Zapf Chancery;"))
|
||||
(:zapf-dingbats f 8)
|
||||
((+ :fonts) (:zapf-dingbats ftech fcharset 2 fprq 2 "Zapf Dingbats;"))
|
||||
|
||||
|
||||
;Color table
|
||||
((+ :rtf-intro) :colortbl)
|
||||
(:colortbl (colortbl ";" ;0
|
||||
red 0 green 0 blue 0 ";" ;1
|
||||
red 0 green 0 blue 255 ";" ;2
|
||||
red 0 green 255 blue 255 ";" ;3
|
||||
red 0 green 255 blue 0 ";" ;4
|
||||
red 255 green 0 blue 255 ";" ;5
|
||||
red 255 green 0 blue 0 ";" ;6
|
||||
red 255 green 255 blue 0 ";" ;7
|
||||
red 255 green 255 blue 255 ";" ;8
|
||||
red 0 green 0 blue 128 ";" ;9
|
||||
red 0 green 128 blue 128 ";" ;10
|
||||
red 0 green 128 blue 0 ";" ;11
|
||||
red 128 green 0 blue 128 ";" ;12
|
||||
red 128 green 0 blue 0 ";" ;13
|
||||
red 128 green 128 blue 0 ";" ;14
|
||||
red 128 green 128 blue 128 ";" ;15
|
||||
red 192 green 192 blue 192 ";")) ;16
|
||||
(:black cf 1)
|
||||
(:blue cf 2)
|
||||
(:turquoise cf 3)
|
||||
(:bright-green cf 4)
|
||||
(:pink cf 5)
|
||||
(:red cf 6)
|
||||
(:yellow cf 7)
|
||||
(:white cf 8)
|
||||
(:dark-blue cf 9)
|
||||
(:teal cf 10)
|
||||
(:green cf 11)
|
||||
(:violet cf 12)
|
||||
(:dark-red cf 13)
|
||||
(:dark-yellow cf 14)
|
||||
(:gray-50 cf 15)
|
||||
(:gray-25 cf 16)
|
||||
|
||||
|
||||
;Misc.
|
||||
(:tab2 tab)
|
||||
(:tab3 tab)
|
||||
(:8-pt fs 16)
|
||||
(:9-pt fs 18)
|
||||
(:10-pt fs 20)
|
||||
(:12-pt fs 24)
|
||||
(:no-language lang 1024)
|
||||
(:english lang 1033)
|
||||
(:english-uk lang 2057)
|
||||
|
||||
(:reset-section sectd)
|
||||
(:new-section sect)
|
||||
(:reset-paragraph pard plain)
|
||||
((:new-paragraph t) par)
|
||||
((:new-line t) line)
|
||||
|
||||
;Symbols (-10 suffix means 10-point, etc.)
|
||||
((:bullet 1) bullet)
|
||||
((:minus 1) endash)
|
||||
((:not-equal 1) u 8800 \' 173)
|
||||
((:less-or-equal 1) u 8804 \' 178)
|
||||
((:greater-or-equal 1) u 8805 \' 179)
|
||||
((:infinity 1) u 8734 \' 176)
|
||||
((:left-single-quote 1) lquote)
|
||||
((:right-single-quote 1) rquote)
|
||||
((:left-double-quote 1) ldblquote)
|
||||
((:right-double-quote 1) rdblquote)
|
||||
((:left-angle-quote 1) u 171 \' 199)
|
||||
((:right-angle-quote 1) u 187 \' 200)
|
||||
((:bottom-10 1) (field (* fldinst "SYMBOL 94 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((: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)))
|
||||
((:member-10 2) (field (* fldinst "SYMBOL 206 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:derives-10 2) (field (* fldinst "SYMBOL 222 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:left-triangle-bracket-10 1) (field (* fldinst "SYMBOL 225 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:right-triangle-bracket-10 1) (field (* fldinst "SYMBOL 241 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:big-plus-10 2) (field (* fldinst "SYMBOL 58 \\f \"Zapf Dingbats\" \\s 10") (fldrslt :zapf-dingbats :10-pt)))
|
||||
|
||||
((:alpha 1) (field (* fldinst "SYMBOL 97 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:beta 1) (field (* fldinst "SYMBOL 98 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:chi 1) (field (* fldinst "SYMBOL 99 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:delta 1) (field (* fldinst "SYMBOL 100 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:epsilon 1) (field (* fldinst "SYMBOL 101 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:phi 1) (field (* fldinst "SYMBOL 102 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:gamma 1) (field (* fldinst "SYMBOL 103 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:eta 1) (field (* fldinst "SYMBOL 104 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:iota 1) (field (* fldinst "SYMBOL 105 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:kappa 1) (field (* fldinst "SYMBOL 107 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:lambda 1) (field (* fldinst "SYMBOL 108 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:mu 1) (field (* fldinst "SYMBOL 109 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:nu 1) (field (* fldinst "SYMBOL 110 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:omicron 1) (field (* fldinst "SYMBOL 111 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:pi 1) (field (* fldinst "SYMBOL 112 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:theta 1) (field (* fldinst "SYMBOL 113 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:rho 1) (field (* fldinst "SYMBOL 114 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:sigma 1) (field (* fldinst "SYMBOL 115 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:tau 1) (field (* fldinst "SYMBOL 116 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:upsilon 1) (field (* fldinst "SYMBOL 117 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:omega 1) (field (* fldinst "SYMBOL 119 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:xi 1) (field (* fldinst "SYMBOL 120 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:psi 1) (field (* fldinst "SYMBOL 121 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:zeta 1) (field (* fldinst "SYMBOL 122 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
|
||||
|
||||
;Styles
|
||||
((+ :rtf-intro) :stylesheet)
|
||||
(:stylesheet (stylesheet :styles))
|
||||
|
||||
(:normal-num 0)
|
||||
(:normal s :normal-num)
|
||||
((+ :styles) (widctlpar :10-pt :english-uk snext :normal-num "Normal;"))
|
||||
|
||||
(:body-text-num 1)
|
||||
(:body-text s :body-text-num qj sa 120 widctlpar :10-pt :english-uk)
|
||||
((+ :styles) (:body-text sbasedon :normal-num snext :body-text-num "Body Text;"))
|
||||
|
||||
(:section-heading-num 2)
|
||||
(:section-heading s :section-heading-num sa 60 keep keepn nowidctlpar hyphpar 0 level 3 b :12-pt :english-uk)
|
||||
((+ :styles) (:section-heading sbasedon :subsection-heading-num snext :body-text-num "heading 3;"))
|
||||
|
||||
(:subsection-heading-num 3)
|
||||
(:subsection-heading s :subsection-heading-num sa 30 keep keepn nowidctlpar hyphpar 0 level 4 b :10-pt :english-uk)
|
||||
((+ :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-uk)
|
||||
((+ :styles) (:grammar-header sbasedon :normal-num snext :grammar-lhs-num "Grammar Header;"))
|
||||
|
||||
(:grammar-lhs-num 12)
|
||||
(:grammar-lhs s :grammar-lhs-num fi -1440 li 1800 sb 120 keep keepn nowidctlpar hyphpar 0 outlinelevel 4 :10-pt :no-language)
|
||||
((+ :styles) (:grammar-lhs sbasedon :grammar-num snext :grammar-rhs-num "Grammar LHS;"))
|
||||
|
||||
(:grammar-lhs-last-num 13)
|
||||
(:grammar-lhs-last s :grammar-lhs-last-num fi -1440 li 1800 sb 120 sa 120 keep nowidctlpar hyphpar 0 outlinelevel 4 :10-pt :no-language)
|
||||
((+ :styles) (:grammar-lhs-last sbasedon :grammar-num snext :grammar-lhs-num "Grammar LHS Last;"))
|
||||
|
||||
(:grammar-rhs-num 14)
|
||||
(:grammar-rhs s :grammar-rhs-num fi -1260 li 1800 keep keepn nowidctlpar tx 720 hyphpar 0 :10-pt :no-language)
|
||||
((+ :styles) (:grammar-rhs sbasedon :grammar-num snext :grammar-rhs-num "Grammar RHS;"))
|
||||
|
||||
(:grammar-rhs-last-num 15)
|
||||
(:grammar-rhs-last s :grammar-rhs-last-num fi -1260 li 1800 sa 120 keep nowidctlpar tx 720 hyphpar 0 :10-pt :no-language)
|
||||
((+ :styles) (:grammar-rhs-last sbasedon :grammar-rhs-num snext :grammar-lhs-num "Grammar RHS Last;"))
|
||||
|
||||
(:grammar-argument-num 16)
|
||||
(:grammar-argument s :grammar-argument-num fi -1440 li 1800 sb 120 sa 120 keep nowidctlpar hyphpar 0 outlinelevel 4 :10-pt :no-language)
|
||||
((+ :styles) (:grammar-argument sbasedon :grammar-num snext :grammar-lhs-num "Grammar Argument;"))
|
||||
|
||||
(:semantics-num 20)
|
||||
(:semantics s :semantics-num li 180 sb 60 sa 60 keep nowidctlpar hyphpar 0 :10-pt :no-language)
|
||||
((+ :styles) (:semantics sbasedon :normal-num snext :semantics-num "Semantics;"))
|
||||
|
||||
(:semantics-next-num 21)
|
||||
(:semantics-next s :semantics-next-num li 540 sa 60 keep nowidctlpar hyphpar 0 :10-pt :no-language)
|
||||
((+ :styles) (:semantics-next sbasedon :semantics-num snext :semantics-next-num "Semantics Next;"))
|
||||
|
||||
(:default-paragraph-font-num 30)
|
||||
(:default-paragraph-font cs :default-paragraph-font-num)
|
||||
((+ :styles) (* :default-paragraph-font additive "Default Paragraph Font;"))
|
||||
|
||||
(:character-literal-num 31)
|
||||
(: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 32)
|
||||
(:character-literal-control cs :character-literal-control-num b 0 :times :dark-blue)
|
||||
((+ :styles) (* :character-literal-control additive sbasedon :default-paragraph-font-num "Character Literal Control;"))
|
||||
|
||||
(:terminal-num 33)
|
||||
(:terminal cs :terminal-num b :palatino :teal :no-language)
|
||||
((+ :styles) (* :terminal additive sbasedon :default-paragraph-font-num "Terminal;"))
|
||||
|
||||
(:terminal-keyword-num 34)
|
||||
(:terminal-keyword cs :terminal-keyword-num b :courier :blue :no-language)
|
||||
((+ :styles) (* :terminal-keyword additive sbasedon :terminal-num "Terminal Keyword;"))
|
||||
|
||||
(:nonterminal-num 35)
|
||||
(:nonterminal cs :nonterminal-num i :palatino :dark-red :no-language)
|
||||
((+ :styles) (* :nonterminal additive sbasedon :default-paragraph-font-num "Nonterminal;"))
|
||||
|
||||
(:nonterminal-attribute-num 36)
|
||||
(:nonterminal-attribute cs :nonterminal-attribute-num i 0)
|
||||
((+ :styles) (* :nonterminal-attribute additive sbasedon :default-paragraph-font-num "Nonterminal Attribute;"))
|
||||
|
||||
(:nonterminal-argument-num 37)
|
||||
(:nonterminal-argument cs :nonterminal-argument-num)
|
||||
((+ :styles) (* :nonterminal-argument additive sbasedon :default-paragraph-font-num "Nonterminal Argument;"))
|
||||
|
||||
(:semantic-keyword-num 40)
|
||||
(:semantic-keyword cs :semantic-keyword-num b :times)
|
||||
((+ :styles) (* :semantic-keyword additive sbasedon :default-paragraph-font-num "Semantic Keyword;"))
|
||||
|
||||
(:type-expression-num 41)
|
||||
(:type-expression cs :type-expression-num :times :red :no-language)
|
||||
((+ :styles) (* :type-expression additive sbasedon :default-paragraph-font-num "Type Expression;"))
|
||||
|
||||
(:type-name-num 42)
|
||||
(:type-name cs :type-name-num scaps :times :red :no-language)
|
||||
((+ :styles) (* :type-name additive sbasedon :type-expression-num "Type Name;"))
|
||||
|
||||
(:field-name-num 43)
|
||||
(:field-name cs :field-name-num :helvetica :red :no-language)
|
||||
((+ :styles) (* :field-name additive sbasedon :type-expression-num "Field Name;"))
|
||||
|
||||
(:global-variable-num 44)
|
||||
(:global-variable cs :global-variable-num i :times :green :no-language)
|
||||
((+ :styles) (* :global-variable additive sbasedon :default-paragraph-font-num "Global Variable;"))
|
||||
|
||||
(:local-variable-num 45)
|
||||
(:local-variable cs :local-variable-num i :times :bright-green :no-language)
|
||||
((+ :styles) (* :local-variable additive sbasedon :default-paragraph-font-num "Local Variable;"))
|
||||
|
||||
(:action-name-num 46)
|
||||
(:action-name cs :action-name-num :zapf-chancery :violet :no-language)
|
||||
((+ :styles) (* :action-name additive sbasedon :default-paragraph-font-num "Action Name;"))
|
||||
|
||||
|
||||
;Document Formatting
|
||||
((+ :rtf-intro) :docfmt)
|
||||
(: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
|
||||
(:invisible v)
|
||||
((:but-not 6) (b "except"))
|
||||
(:subscript sub)
|
||||
(:superscript super)
|
||||
(:plain-subscript b 0 i 0 :subscript)
|
||||
((:action-begin 1) "[")
|
||||
((:action-end 1) "]")
|
||||
((:vector-begin 1) (b "["))
|
||||
((:vector-end 1) (b "]"))
|
||||
((:empty-vector 2) (b "[]"))
|
||||
((:vector-append 2) :big-plus-10)
|
||||
((:tuple-begin 1) (b :left-triangle-bracket-10))
|
||||
((:tuple-end 1) (b :right-triangle-bracket-10))
|
||||
((:unit 4) (:global-variable "unit"))
|
||||
((:true 4) (:global-variable "true"))
|
||||
((:false 5) (:global-variable "false"))
|
||||
))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; SIMPLE LINE BREAKER
|
||||
|
||||
(defparameter *limited-line-right-margin* 100)
|
||||
|
||||
; Housekeeping dynamic variables
|
||||
(defvar *current-limited-lines*) ;Items written so far via break-line to the innermost write-limited-lines
|
||||
(defvar *current-limited-lines-non-empty*) ;True if something was written to *current-limited-lines*
|
||||
(defvar *current-limited-position*) ;Number of characters written since the last newline to *current-limited-lines*
|
||||
|
||||
|
||||
; Capture the text written by the emitter function to its single parameter
|
||||
; (an output stream), dividing the text as specified by dynamically scoped calls
|
||||
; to break-line. Return the text as a base-string.
|
||||
(defun write-limited-lines (emitter)
|
||||
(let ((limited-stream (make-string-output-stream :element-type 'base-character))
|
||||
(*current-limited-lines* (make-string-output-stream :element-type 'base-character))
|
||||
(*current-limited-lines-non-empty* nil)
|
||||
(*current-limited-position* 0))
|
||||
(funcall emitter limited-stream)
|
||||
(break-line limited-stream)
|
||||
(get-output-stream-string *current-limited-lines*)))
|
||||
|
||||
|
||||
; Capture the text written by the emitter body to stream-var,
|
||||
; dividing the text as specified by dynamically scoped calls
|
||||
; to break-line. Write the result to the stream-var stream.
|
||||
(defmacro write-limited-block (stream-var &body emitter)
|
||||
`(progn
|
||||
(write-string
|
||||
(write-limited-lines #'(lambda (,stream-var) ,@emitter))
|
||||
,stream-var)
|
||||
nil))
|
||||
|
||||
|
||||
; Indicate that this is a potential place for a line break in the stream provided
|
||||
; by write-limited-lines. If subdivide is true, also indicate that line breaks can
|
||||
; be inserted anywhere between this point and the last such point indicated by break-line
|
||||
; (or the beginning of write-limited-lines, whichever came last).
|
||||
(defun break-line (limited-stream &optional subdivide)
|
||||
(let* ((new-chars (get-output-stream-string limited-stream))
|
||||
(length (length new-chars)))
|
||||
(unless (zerop length)
|
||||
(labels
|
||||
((subdivide-new-chars (start)
|
||||
(let ((length-remaining (- length start))
|
||||
(room-on-line (- *limited-line-right-margin* *current-limited-position*)))
|
||||
(if (>= room-on-line length-remaining)
|
||||
(progn
|
||||
(write-string new-chars *current-limited-lines* :start start)
|
||||
(incf *current-limited-position* length-remaining))
|
||||
(let ((end (+ start room-on-line)))
|
||||
(write-string new-chars *current-limited-lines* :start start :end end)
|
||||
(write-char #\newline *current-limited-lines*)
|
||||
(setq *current-limited-position* 0)
|
||||
(subdivide-new-chars end))))))
|
||||
|
||||
(let ((position (+ *current-limited-position* length))
|
||||
(has-newlines (find #\newline new-chars)))
|
||||
(cond
|
||||
((or has-newlines
|
||||
(and (> position *limited-line-right-margin*) (not subdivide)))
|
||||
(when *current-limited-lines-non-empty*
|
||||
(write-char #\newline *current-limited-lines*))
|
||||
(write-string new-chars *current-limited-lines*)
|
||||
;Force a line break if break-line is called again and the current
|
||||
;new-chars contained a line break.
|
||||
(setq *current-limited-position*
|
||||
(if has-newlines
|
||||
(1+ *limited-line-right-margin*)
|
||||
length)))
|
||||
((<= position *limited-line-right-margin*)
|
||||
(write-string new-chars *current-limited-lines*)
|
||||
(setq *current-limited-position* position))
|
||||
((>= *current-limited-position* *limited-line-right-margin*)
|
||||
(write-char #\newline *current-limited-lines*)
|
||||
(setq *current-limited-position* 0)
|
||||
(subdivide-new-chars 0))
|
||||
(t (subdivide-new-chars 0)))
|
||||
(setq *current-limited-lines-non-empty* t))))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; RTF READER
|
||||
|
||||
|
||||
; Return true if char can be a part of an RTF control word.
|
||||
(defun rtf-control-word-char? (char)
|
||||
(and (char>= char #\a) (char<= char #\z)))
|
||||
|
||||
|
||||
; Read RTF from the character stream and return it in list form.
|
||||
; Each { ... } group is a sublist.
|
||||
; Each RTF control symbol or word is represented by a lisp symbol.
|
||||
; If an RTF control has a numeric argument, then its lisp symbol is followed
|
||||
; by an integer equal to the argument's value.
|
||||
; Newlines not escaped by backslashes are ignored.
|
||||
(defun read-rtf (stream)
|
||||
(labels
|
||||
((read (&optional (eof-error-p t))
|
||||
(read-char stream eof-error-p nil))
|
||||
|
||||
(read-group (nested)
|
||||
(let ((char (read nested)))
|
||||
(case char
|
||||
((nil) nil)
|
||||
(#\} (if nested
|
||||
nil
|
||||
(error "Mismatched }")))
|
||||
(#\{ (cons
|
||||
(read-group t)
|
||||
(read-group nested)))
|
||||
(#\\ (append
|
||||
(read-control)
|
||||
(read-group nested)))
|
||||
(#\newline (read-group nested))
|
||||
(t (read-text nested (list char))))))
|
||||
|
||||
(read-text (nested chars)
|
||||
(let ((char (read nested)))
|
||||
(case char
|
||||
((nil)
|
||||
(list (coerce (nreverse chars) 'string)))
|
||||
((#\{ #\} #\\)
|
||||
(cons (coerce (nreverse chars) 'string)
|
||||
(progn
|
||||
(unread-char char stream)
|
||||
(read-group nested))))
|
||||
(#\newline (read-text nested chars))
|
||||
(t (read-text nested (cons char chars))))))
|
||||
|
||||
(read-integer (value need-digit)
|
||||
(let* ((char (read))
|
||||
(digit (digit-char-p char)))
|
||||
(cond
|
||||
(digit (read-integer (+ (* value 10) digit) nil))
|
||||
(need-digit (error "Empty number"))
|
||||
((eql char #\space) value)
|
||||
(t (unread-char char stream)
|
||||
value))))
|
||||
|
||||
(read-hex (n-digits)
|
||||
(let ((value 0))
|
||||
(dotimes (n n-digits)
|
||||
(let ((digit (digit-char-p (read) 16)))
|
||||
(unless digit
|
||||
(error "Bad hex digit"))
|
||||
(setq value (+ (* value 16) digit))))
|
||||
value))
|
||||
|
||||
(read-control ()
|
||||
(let ((char (read)))
|
||||
(if (rtf-control-word-char? char)
|
||||
(let* ((control-string (read-control-word (list char)))
|
||||
(control-symbol (intern (string-upcase control-string)))
|
||||
(char (read)))
|
||||
(case char
|
||||
(#\space (list control-symbol))
|
||||
(#\- (list control-symbol (- (read-integer 0 t))))
|
||||
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
|
||||
(unread-char char stream)
|
||||
(list control-symbol (read-integer 0 t)))
|
||||
(t (unread-char char stream)
|
||||
(list control-symbol))))
|
||||
(let* ((control-string (string char))
|
||||
(control-symbol (intern (string-upcase control-string))))
|
||||
(if (eq control-symbol '\')
|
||||
(list control-symbol (read-hex 2))
|
||||
(list control-symbol))))))
|
||||
|
||||
(read-control-word (chars)
|
||||
(let ((char (read)))
|
||||
(if (rtf-control-word-char? char)
|
||||
(read-control-word (cons char chars))
|
||||
(progn
|
||||
(unread-char char stream)
|
||||
(coerce (nreverse chars) 'string))))))
|
||||
|
||||
(read-group nil)))
|
||||
|
||||
|
||||
; Read RTF from the text file with the given name (relative to the
|
||||
; local directory) and return it in list form.
|
||||
(defun read-rtf-from-local-file (filename)
|
||||
(with-open-file (stream (merge-pathnames filename *semantic-engine-directory*)
|
||||
:direction :input)
|
||||
(read-rtf stream)))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; RTF WRITER
|
||||
|
||||
|
||||
(defconstant *rtf-special* '(#\\ #\{ #\}))
|
||||
|
||||
|
||||
; Return the string with characters in *rtf-special* preceded by backslashes.
|
||||
; If there are no such characters, the returned string may be eq to the input string.
|
||||
(defun escape-rtf (string)
|
||||
(let ((i (position-if #'(lambda (char) (member char *rtf-special*)) string)))
|
||||
(if i
|
||||
(let* ((string-length (length string))
|
||||
(result-string (make-array string-length :element-type 'base-character :adjustable t :fill-pointer i)))
|
||||
(replace result-string string)
|
||||
(do ((i i (1+ i)))
|
||||
((= i string-length))
|
||||
(let ((char (char string i)))
|
||||
(when (member char *rtf-special*)
|
||||
(vector-push-extend #\\ result-string))
|
||||
(vector-push-extend char result-string)))
|
||||
result-string)
|
||||
string)))
|
||||
|
||||
|
||||
; Write RTF to the character stream. See read-rtf for a description
|
||||
; of the layout of the rtf list.
|
||||
(defun write-rtf (rtf &optional (stream t))
|
||||
(labels
|
||||
((write-group-contents (rtf stream)
|
||||
(let ((first-rtf (first rtf))
|
||||
(rest-rtf (rest rtf)))
|
||||
(cond
|
||||
((listp first-rtf)
|
||||
(write-group first-rtf stream t))
|
||||
((stringp first-rtf)
|
||||
(write-string (escape-rtf first-rtf) stream)
|
||||
(break-line stream t))
|
||||
((symbolp first-rtf)
|
||||
(write-char #\\ stream)
|
||||
(write first-rtf :stream stream)
|
||||
(cond
|
||||
((alpha-char-p (char (symbol-name first-rtf) 0))
|
||||
(when (integerp (first rest-rtf))
|
||||
(write (first rest-rtf) :stream stream)
|
||||
(setq rest-rtf (rest rest-rtf)))
|
||||
(let ((first-rest (first rest-rtf)))
|
||||
(when (and (stringp first-rest)
|
||||
(or (zerop (length first-rest))
|
||||
(let ((ch (char first-rest 0)))
|
||||
(or (alphanumericp ch)
|
||||
(eql ch #\space)
|
||||
(eql ch #\-)
|
||||
(eql ch #\+)))))
|
||||
(write-char #\space stream))))
|
||||
((eq first-rtf '\')
|
||||
(unless (integerp (first rest-rtf))
|
||||
(error "Bad rtf: ~S" rtf))
|
||||
(format stream "~2,'0x" (first rest-rtf))
|
||||
(setq rest-rtf (rest rest-rtf)))))
|
||||
(t (error "Bad rtf: ~S" rtf)))
|
||||
(when rest-rtf
|
||||
(break-line stream)
|
||||
(write-group-contents rest-rtf stream))))
|
||||
|
||||
(write-group (rtf stream nested)
|
||||
(write-limited-block stream
|
||||
(when nested
|
||||
(write-char #\{ stream))
|
||||
(when rtf
|
||||
(write-group-contents rtf stream))
|
||||
(when nested
|
||||
(write-char #\} stream)))))
|
||||
|
||||
(with-standard-io-syntax
|
||||
(let ((*print-readably* nil)
|
||||
(*print-escape* nil)
|
||||
(*print-case* :downcase))
|
||||
(write-group rtf stream nil)))))
|
||||
|
||||
|
||||
; Write RTF to the text file with the given name (relative to the
|
||||
; local directory).
|
||||
(defun write-rtf-to-local-file (filename rtf)
|
||||
(with-open-file (stream (merge-pathnames filename *semantic-engine-directory*)
|
||||
:direction :output
|
||||
:if-exists :supersede
|
||||
#+mcl :external-format #+mcl "RTF "
|
||||
#+mcl :mac-file-creator #+mcl "MSWD")
|
||||
(write-rtf rtf stream)))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; RTF STREAMS
|
||||
|
||||
(defstruct (rtf-stream (:include markup-stream)
|
||||
(:constructor allocate-rtf-stream (env head tail level logical-position))
|
||||
(:copier nil)
|
||||
(:predicate rtf-stream?))
|
||||
(style nil :type symbol)) ;Current section or paragraph style or nil if none or emitting paragraph contents
|
||||
|
||||
|
||||
(defmethod print-object ((rtf-stream rtf-stream) stream)
|
||||
(print-unreadable-object (rtf-stream stream :identity t)
|
||||
(write-string "rtf-stream" stream)))
|
||||
|
||||
|
||||
; Make a new, empty, open rtf-stream with the given definitions for its markup-env.
|
||||
(defun make-rtf-stream (markup-env level &optional logical-position)
|
||||
(let ((head (list nil)))
|
||||
(allocate-rtf-stream markup-env head head level logical-position)))
|
||||
|
||||
|
||||
; Make a new, empty, open, top-level rtf-stream with the given definitions
|
||||
; for its markup-env.
|
||||
(defun make-top-level-rtf-stream (rtf-definitions)
|
||||
(let ((head (list nil))
|
||||
(markup-env (make-markup-env)))
|
||||
(markup-env-define-alist markup-env rtf-definitions)
|
||||
(allocate-rtf-stream markup-env head head *markup-stream-top-level* nil)))
|
||||
|
||||
|
||||
; Append a block to the end of the rtf-stream. The block may be inlined
|
||||
; if nothing else follows it in the rtf-stream.
|
||||
(defun rtf-stream-append-or-inline-block (rtf-stream block)
|
||||
(assert-type block list)
|
||||
(when block
|
||||
(let ((pretail (markup-stream-tail rtf-stream)))
|
||||
(markup-stream-append1 rtf-stream block)
|
||||
(setf (markup-stream-pretail rtf-stream) pretail))))
|
||||
|
||||
|
||||
; Return the approximate width of the rtf item; return t if it is a line break.
|
||||
; Also allow rtf groups as long as they do not contain line breaks.
|
||||
(defmethod markup-group-width ((rtf-stream rtf-stream) item)
|
||||
(if (consp item)
|
||||
(reduce #'+ item :key #'(lambda (subitem) (markup-group-width rtf-stream subitem)))
|
||||
(markup-width rtf-stream item)))
|
||||
|
||||
|
||||
; Create a top-level rtf-stream and call emitter to emit its contents.
|
||||
; emitter takes one argument -- an rtf-stream to which it should emit paragraphs.
|
||||
; Return the top-level rtf-stream.
|
||||
(defun depict-rtf-top-level (emitter)
|
||||
(let* ((top-rtf-stream (make-top-level-rtf-stream *rtf-definitions*))
|
||||
(rtf-stream (make-rtf-stream (markup-stream-env top-rtf-stream) *markup-stream-paragraph-level*)))
|
||||
(markup-stream-append1 rtf-stream ':rtf-intro)
|
||||
(markup-stream-append1 rtf-stream ':reset-section)
|
||||
(funcall emitter rtf-stream)
|
||||
(markup-stream-append1 top-rtf-stream (markup-stream-unexpanded-output rtf-stream))
|
||||
top-rtf-stream))
|
||||
|
||||
|
||||
; Create a top-level rtf-stream and call emitter to emit its contents.
|
||||
; emitter takes one argument -- an rtf-stream to which it should emit paragraphs.
|
||||
; Write the resulting RTF to the text file with the given name (relative to the
|
||||
; local directory).
|
||||
(defun depict-rtf-to-local-file (filename emitter)
|
||||
(let ((top-rtf-stream (depict-rtf-top-level emitter)))
|
||||
(write-rtf-to-local-file filename (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 emitter)
|
||||
(declare (ignore block-style))
|
||||
(assert-true (= (markup-stream-level rtf-stream) *markup-stream-paragraph-level*))
|
||||
(funcall emitter rtf-stream))
|
||||
|
||||
|
||||
(defmethod depict-paragraph-f ((rtf-stream rtf-stream) paragraph-style emitter)
|
||||
(assert-true (= (markup-stream-level rtf-stream) *markup-stream-paragraph-level*))
|
||||
(assert-true (and paragraph-style (symbolp paragraph-style)))
|
||||
(unless (eq paragraph-style (rtf-stream-style rtf-stream))
|
||||
(markup-stream-append1 rtf-stream ':reset-paragraph)
|
||||
(markup-stream-append1 rtf-stream paragraph-style))
|
||||
(setf (rtf-stream-style rtf-stream) nil)
|
||||
(setf (markup-stream-level rtf-stream) *markup-stream-content-level*)
|
||||
(setf (markup-stream-logical-position rtf-stream) (make-logical-position))
|
||||
(prog1
|
||||
(funcall emitter rtf-stream)
|
||||
(setf (markup-stream-level rtf-stream) *markup-stream-paragraph-level*)
|
||||
(setf (rtf-stream-style rtf-stream) paragraph-style)
|
||||
(setf (markup-stream-logical-position rtf-stream) nil)
|
||||
(markup-stream-append1 rtf-stream ':new-paragraph)))
|
||||
|
||||
|
||||
(defmethod depict-char-style-f ((rtf-stream rtf-stream) char-style emitter)
|
||||
(assert-true (>= (markup-stream-level rtf-stream) *markup-stream-content-level*))
|
||||
(assert-true (and char-style (symbolp char-style)))
|
||||
(let ((inner-rtf-stream (make-rtf-stream (markup-stream-env rtf-stream) *markup-stream-content-level* (markup-stream-logical-position rtf-stream))))
|
||||
(markup-stream-append1 inner-rtf-stream char-style)
|
||||
(prog1
|
||||
(funcall emitter inner-rtf-stream)
|
||||
(rtf-stream-append-or-inline-block rtf-stream (markup-stream-unexpanded-output inner-rtf-stream)))))
|
||||
|
||||
|
||||
#|
|
||||
(setq r (read-rtf-from-local-file "SampleStyles.rtf"))
|
||||
(write-rtf-to-local-file "Y.rtf" r)
|
||||
|#
|
||||
|
|
@ -0,0 +1,507 @@
|
|||
;;; The contents of this file are subject to the Netscape Public License
|
||||
;;; Version 1.0 (the "NPL"); you may not use this file except in
|
||||
;;; compliance with the NPL. You may obtain a copy of the NPL at
|
||||
;;; http://www.mozilla.org/NPL/
|
||||
;;;
|
||||
;;; Software distributed under the NPL is distributed on an "AS IS" basis,
|
||||
;;; WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
|
||||
;;; for the specific language governing rights and limitations under the
|
||||
;;; NPL.
|
||||
;;;
|
||||
;;; The Initial Developer of this code under the NPL is Netscape
|
||||
;;; Communications Corporation. Portions created by Netscape are
|
||||
;;; Copyright (C) 1998 Netscape Communications Corporation. All Rights
|
||||
;;; Reserved.
|
||||
|
||||
;;;
|
||||
;;; Handy lisp utilities
|
||||
;;;
|
||||
;;; Waldemar Horwat (waldemar@netscape.com)
|
||||
;;;
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; MCL FIXES
|
||||
|
||||
|
||||
(setq *print-right-margin* 150)
|
||||
|
||||
;;; Fix name-char and char-name.
|
||||
#+mcl
|
||||
(locally
|
||||
(declare (optimize (speed 3) (safety 0) (debug 1)))
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(setq *warn-if-redefine* nil)
|
||||
(setq *warn-if-redefine-kernel* nil))
|
||||
|
||||
(defun char-name (c)
|
||||
(dolist (e ccl::*name-char-alist*)
|
||||
(declare (list e))
|
||||
(when (eq c (cdr e))
|
||||
(return-from char-name (car e))))
|
||||
(let ((code (char-code c)))
|
||||
(declare (fixnum code))
|
||||
(cond ((< code #x100)
|
||||
(unless (and (>= code 32) (<= code 216) (/= code 127))
|
||||
(format nil "x~2,'0X" code)))
|
||||
(t (format nil "u~4,'0X" code)))))
|
||||
|
||||
(defun name-char (name)
|
||||
(if (characterp name)
|
||||
name
|
||||
(let* ((name (string name))
|
||||
(namelen (length name)))
|
||||
(declare (fixnum namelen))
|
||||
(or (cdr (assoc name ccl::*name-char-alist* :test #'string-equal))
|
||||
(if (= namelen 1)
|
||||
(char name 0)
|
||||
(when (>= namelen 2)
|
||||
(flet
|
||||
((number-char (name base lg-base)
|
||||
(let ((n 0))
|
||||
(dotimes (i (length name) (code-char n))
|
||||
(let ((code (digit-char-p (char name i) base)))
|
||||
(if code
|
||||
(setq n (logior code (ash n lg-base)))
|
||||
(return)))))))
|
||||
(case (char name 0)
|
||||
(#\^
|
||||
(when (= namelen 2)
|
||||
(code-char (the fixnum (logxor (the fixnum (char-code (char-upcase (char name 1)))) #x40)))))
|
||||
((#\x #\X #\u #\U)
|
||||
(number-char (subseq name 1) 16 4))
|
||||
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7)
|
||||
(number-char name 8 3))))))))))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(setq *warn-if-redefine* t)
|
||||
(setq *warn-if-redefine-kernel* t)))
|
||||
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; READER SYNTAX
|
||||
|
||||
; Define #?num to produce a character with code given by the hexadecimal number num.
|
||||
; (This is a portable extension; the #\u syntax installed above does the same thing
|
||||
; but is not portable.)
|
||||
(set-dispatch-macro-character
|
||||
#\# #\?
|
||||
#'(lambda (stream subchar arg)
|
||||
(declare (ignore subchar arg))
|
||||
(let ((*read-base* 16))
|
||||
(code-char (read stream t nil t)))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; MACROS
|
||||
|
||||
; (list*-bind (var1 var2 ... varn) expr body):
|
||||
; evaluates expr to obtain a value v;
|
||||
; binds var1, var2, ..., varn such that (list* var1 var2 ... varn) is equal to v;
|
||||
; evaluates body with these bindings;
|
||||
; returns the result values from the body.
|
||||
(defmacro list*-bind ((var1 &rest vars) expr &body body)
|
||||
(labels
|
||||
((gen-let*-bindings (var1 vars expr)
|
||||
(if vars
|
||||
(let ((expr-var (gensym "REST")))
|
||||
(list*
|
||||
(list expr-var expr)
|
||||
(list var1 (list 'car expr-var))
|
||||
(gen-let*-bindings (car vars) (cdr vars) (list 'cdr expr-var))))
|
||||
(list
|
||||
(list var1 expr)))))
|
||||
(list* 'let* (gen-let*-bindings var1 vars expr) body)))
|
||||
|
||||
(set-pprint-dispatch '(cons (member list*-bind))
|
||||
(pprint-dispatch '(multiple-value-bind () ())))
|
||||
|
||||
|
||||
; (multiple-value-map-bind (var1 var2 ... varn) f (src1 src2 ... srcm) body)
|
||||
; evaluates src1, src2, ..., srcm to obtain lists l1, l2, ..., lm;
|
||||
; calls f on corresponding elements of lists l1, ..., lm; each such call should return n values v1 v2 ... vn;
|
||||
; binds var1, var2, ..., varn such var1 is the list of all v1's, var2 is the list of all v2's, etc.;
|
||||
; evaluates body with these bindings;
|
||||
; returns the result values from the body.
|
||||
(defmacro multiple-value-map-bind ((&rest vars) f (&rest srcs) &body body)
|
||||
(let ((n (length vars))
|
||||
(m (length srcs))
|
||||
(fun (gensym "F"))
|
||||
(ss nil)
|
||||
(vs nil)
|
||||
(accumulators nil))
|
||||
(dotimes (i n)
|
||||
(push (gensym "V") vs)
|
||||
(push (gensym "ACC") accumulators))
|
||||
(dotimes (i m)
|
||||
(push (gensym "S") ss))
|
||||
`(let ((,fun ,f)
|
||||
,@(mapcar #'(lambda (acc) (list acc nil)) accumulators))
|
||||
(mapc #'(lambda ,ss
|
||||
(multiple-value-bind ,vs (funcall ,fun ,@ss)
|
||||
,@(mapcar #'(lambda (accumulator v) (list 'push v accumulator))
|
||||
accumulators vs)))
|
||||
,@srcs)
|
||||
(let ,(mapcar #'(lambda (var accumulator) (list var (list 'nreverse accumulator)))
|
||||
vars accumulators)
|
||||
,@body))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; VALUE ASSERTS
|
||||
|
||||
(defconstant *value-asserts* t)
|
||||
|
||||
; Assert that (test value) returns non-nil. Return value.
|
||||
(defmacro assert-value (value test &rest format-and-parameters)
|
||||
(if *value-asserts*
|
||||
(let ((v (gensym "VALUE")))
|
||||
`(let ((,v ,value))
|
||||
(unless (,test ,v)
|
||||
,(if format-and-parameters
|
||||
`(error ,@format-and-parameters)
|
||||
`(error "~S doesn't satisfy ~S" ',value ',test)))
|
||||
,v))
|
||||
value))
|
||||
|
||||
|
||||
; Assert that value is non-nil. Return value.
|
||||
(defmacro assert-non-null (value &rest format-and-parameters)
|
||||
`(assert-value ,value identity .
|
||||
,(or format-and-parameters
|
||||
`("~S is null" ',value))))
|
||||
|
||||
|
||||
; Assert that value is non-nil. Return nil.
|
||||
; Do not evaluate value in nondebug versions.
|
||||
(defmacro assert-true (value &rest format-and-parameters)
|
||||
(if *value-asserts*
|
||||
`(unless ,value
|
||||
,(if format-and-parameters
|
||||
`(error ,@format-and-parameters)
|
||||
`(error "~S is false" ',value)))
|
||||
nil))
|
||||
|
||||
|
||||
; Assert that expr returns n values. Return those values.
|
||||
(defmacro assert-n-values (n expr)
|
||||
(if *value-asserts*
|
||||
(let ((v (gensym "VALUES")))
|
||||
`(let ((,v (multiple-value-list ,expr)))
|
||||
(unless (= (length ,v) ,n)
|
||||
(error "~S returns ~D values instead of ~D" ',expr (length ,v) ',n))
|
||||
(values-list ,v)))
|
||||
expr))
|
||||
|
||||
; Assert that expr returns one value. Return that value.
|
||||
(defmacro assert-one-value (expr)
|
||||
`(assert-n-values 1 ,expr))
|
||||
|
||||
; Assert that expr returns two values. Return those values.
|
||||
(defmacro assert-two-values (expr)
|
||||
`(assert-n-values 2 ,expr))
|
||||
|
||||
; Assert that expr returns three values. Return those values.
|
||||
(defmacro assert-three-values (expr)
|
||||
`(assert-n-values 3 ,expr))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; STRUCTURED TYPES
|
||||
|
||||
(defconstant *type-asserts* t)
|
||||
|
||||
(defun tuple? (value structured-types)
|
||||
(if (endp structured-types)
|
||||
(null value)
|
||||
(and (consp value)
|
||||
(structured-type? (car value) (first structured-types))
|
||||
(tuple? (cdr value) (rest structured-types)))))
|
||||
|
||||
(defun list-of? (value structured-type)
|
||||
(or
|
||||
(null value)
|
||||
(and (consp value)
|
||||
(structured-type? (car value) structured-type)
|
||||
(list-of? (cdr value) structured-type))))
|
||||
|
||||
|
||||
; Return true if value has the given structured-type.
|
||||
; A structured-type can be a Common Lisp type or one of the forms below:
|
||||
;
|
||||
; (cons t1 t2) is the type of pairs whose car has structured-type t1 and
|
||||
; cdr has structured-type t2.
|
||||
;
|
||||
; (tuple t1 t2 ... tn) is the type of n-element lists whose first element
|
||||
; has structured-type t1, second element has structured-type t2, ...,
|
||||
; and last element has structured-type tn.
|
||||
;
|
||||
; (list t) is the type of lists all of whose elements have structured-type t.
|
||||
;
|
||||
(defun structured-type? (value structured-type)
|
||||
(cond
|
||||
((consp structured-type)
|
||||
(case (first structured-type)
|
||||
(cons (and (consp value)
|
||||
(structured-type? (car value) (second structured-type))
|
||||
(structured-type? (cdr value) (third structured-type))))
|
||||
(tuple (tuple? value (rest structured-type)))
|
||||
(list (list-of? value (second structured-type)))
|
||||
(t (typep value structured-type))))
|
||||
((null structured-type) nil)
|
||||
(t (typep value structured-type))))
|
||||
|
||||
|
||||
; Ensure that value has type given by typespec
|
||||
; (which should not be quoted). Return the value.
|
||||
(defmacro assert-type (value structured-type)
|
||||
(if *type-asserts*
|
||||
(let ((v (gensym "VALUE")))
|
||||
`(let ((,v ,value))
|
||||
(unless (structured-type? ,v ',structured-type)
|
||||
(error "~S should have type ~S" ,v ',structured-type))
|
||||
,v))
|
||||
value))
|
||||
|
||||
(deftype bool () '(member nil t))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; GENERAL UTILITIES
|
||||
|
||||
|
||||
; f must be either a function, a symbol, or a list of the form (setf <symbol>).
|
||||
; If f is a function or has a function binding, return that function; otherwise return nil.
|
||||
(defun callable (f)
|
||||
(cond
|
||||
((functionp f) f)
|
||||
((fboundp f) (fdefinition f))
|
||||
(t nil)))
|
||||
|
||||
|
||||
; Return the first character of symbol's name or nil if s's name has zero length.
|
||||
(defun first-symbol-char (symbol)
|
||||
(let ((name (symbol-name symbol)))
|
||||
(when (> (length name) 0)
|
||||
(char name 0))))
|
||||
|
||||
|
||||
(defconstant *get2-nonce* (if (boundp '*get2-nonce*) (symbol-value '*get2-nonce*) (gensym)))
|
||||
|
||||
; Perform a get except that return two values:
|
||||
; The value returned from the get or nil if the property is not present
|
||||
; t if the property is present or nil if not.
|
||||
(defun get2 (symbol property)
|
||||
(let ((value (get symbol property *get2-nonce*)))
|
||||
(if (eq value *get2-nonce*)
|
||||
(values nil nil)
|
||||
(values value t))))
|
||||
|
||||
|
||||
; Return a list of all the keys in the hash table.
|
||||
(defun hash-table-keys (hash-table)
|
||||
(let ((keys nil))
|
||||
(maphash #'(lambda (key value)
|
||||
(declare (ignore value))
|
||||
(push key keys))
|
||||
hash-table)
|
||||
keys))
|
||||
|
||||
|
||||
; Return a list of all the keys in the hash table sorted by their string representations.
|
||||
(defun sorted-hash-table-keys (hash-table)
|
||||
(with-standard-io-syntax
|
||||
(let ((*print-readably* nil)
|
||||
(*print-escape* nil))
|
||||
(sort (hash-table-keys hash-table) #'string< :key #'write-to-string))))
|
||||
|
||||
|
||||
; Given an association list ((key1 . data1) (key2 . data2) ... (keyn datan)),
|
||||
; produce another association list whose keys are sets of the keys of the original list,
|
||||
; where the data elements of each such set are equal according to the given test function.
|
||||
; The keys within each set are listed in the same order as in the original list.
|
||||
; Set X comes before set Y if X contains a key earlier in the original list than any
|
||||
; key in Y.
|
||||
(defun collect-equivalences (alist &key (test #'eql))
|
||||
(if (endp alist)
|
||||
nil
|
||||
(let* ((element (car alist))
|
||||
(key (car element))
|
||||
(data (cdr element))
|
||||
(rest (cdr alist)))
|
||||
(if (rassoc data rest :test test)
|
||||
(let ((filtered-rest nil)
|
||||
(additional-keys nil))
|
||||
(dolist (elt rest)
|
||||
(if (funcall test data (cdr elt))
|
||||
(push (car elt) additional-keys)
|
||||
(push elt filtered-rest)))
|
||||
(acons (cons key (nreverse additional-keys)) data
|
||||
(collect-equivalences (nreverse filtered-rest) :test test)))
|
||||
(acons (list key) data (collect-equivalences rest :test test))))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; BITMAPS
|
||||
|
||||
; Treating integer m as a bitmap, call f on the number of each bit set in m.
|
||||
(defun bitmap-each-bit (f m)
|
||||
(assert-true (>= m 0))
|
||||
(dotimes (i (integer-length m))
|
||||
(when (logbitp i m)
|
||||
(funcall f i))))
|
||||
|
||||
|
||||
; Treating integer m as a bitmap, return a sorted list of disjoint, nonadjacent ranges
|
||||
; of bits set in m. Each range is a pair (x . y) and indicates that bits numbered x through
|
||||
; y, inclusive, are set in m. If m is negative, the last range will be a pair (x . :infinity).
|
||||
(defun bitmap-to-ranges (m)
|
||||
(labels
|
||||
((bitmap-to-ranges-sub (m ranges)
|
||||
(if (zerop m)
|
||||
ranges
|
||||
(let* ((hi (integer-length m))
|
||||
(m (- m (ash 1 hi)))
|
||||
(lo (integer-length m))
|
||||
(m (+ m (ash 1 lo))))
|
||||
(bitmap-to-ranges-sub m (acons lo (1- hi) ranges))))))
|
||||
(if (minusp m)
|
||||
(let* ((lo (integer-length m))
|
||||
(m (+ m (ash 1 lo))))
|
||||
(bitmap-to-ranges-sub m (list (cons lo :infinity))))
|
||||
(bitmap-to-ranges-sub m nil))))
|
||||
|
||||
|
||||
; Same as bitmap-to-ranges but abbreviate pairs (x . x) by x.
|
||||
(defun bitmap-to-abbreviated-ranges (m)
|
||||
(mapcar #'(lambda (range)
|
||||
(if (eql (car range) (cdr range))
|
||||
(car range)
|
||||
range))
|
||||
(bitmap-to-ranges m)))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; PACKAGES
|
||||
|
||||
; Call f on each external symbol defined in the package.
|
||||
(defun each-package-external-symbol (package f)
|
||||
(with-package-iterator (iter package :external)
|
||||
(loop
|
||||
(multiple-value-bind (present symbol) (iter)
|
||||
(unless present
|
||||
(return))
|
||||
(funcall f symbol)))))
|
||||
|
||||
|
||||
; Return a list of all external symbols defined in the package.
|
||||
(defun package-external-symbols (package)
|
||||
(with-package-iterator (iter package :external)
|
||||
(let ((list nil))
|
||||
(loop
|
||||
(multiple-value-bind (present symbol) (iter)
|
||||
(unless present
|
||||
(return))
|
||||
(push symbol list)))
|
||||
list)))
|
||||
|
||||
|
||||
; Return a sorted list of all external symbols defined in the package.
|
||||
(defun sorted-package-external-symbols (package)
|
||||
(sort (package-external-symbols package) #'string<))
|
||||
|
||||
|
||||
; Call f on each internal symbol defined in the package.
|
||||
(defun each-package-internal-symbol (package f)
|
||||
(with-package-iterator (iter package :internal)
|
||||
(loop
|
||||
(multiple-value-bind (present symbol) (iter)
|
||||
(unless present
|
||||
(return))
|
||||
(funcall f symbol)))))
|
||||
|
||||
|
||||
; Return a list of all internal symbols defined in the package.
|
||||
(defun package-internal-symbols (package)
|
||||
(with-package-iterator (iter package :internal)
|
||||
(let ((list nil))
|
||||
(loop
|
||||
(multiple-value-bind (present symbol) (iter)
|
||||
(unless present
|
||||
(return))
|
||||
(push symbol list)))
|
||||
list)))
|
||||
|
||||
|
||||
; Return a sorted list of all internal symbols defined in the package.
|
||||
(defun sorted-package-internal-symbols (package)
|
||||
(sort (package-internal-symbols package) #'string<))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; SETS
|
||||
|
||||
(defstruct (set (:constructor allocate-set (elts-hash)))
|
||||
(elts-hash nil :type hash-table :read-only t))
|
||||
|
||||
|
||||
; Make and return a new set.
|
||||
(defun make-set (&optional (test #'eql))
|
||||
(allocate-set (make-hash-table :test test)))
|
||||
|
||||
|
||||
; Add values to the set, modifying the set in place.
|
||||
; Return the set.
|
||||
(defun set-add (set &rest values)
|
||||
(let ((elements (set-elts-hash set)))
|
||||
(dolist (value values)
|
||||
(setf (gethash value elements) t)))
|
||||
set)
|
||||
|
||||
|
||||
; Return true if element is a member of the set.
|
||||
(defun set-member (set element)
|
||||
(gethash element (set-elts-hash set)))
|
||||
|
||||
|
||||
; Return the set as a list.
|
||||
(defun set-elements (set)
|
||||
(let ((elements nil))
|
||||
(maphash #'(lambda (key value)
|
||||
(declare (ignore value))
|
||||
(push key elements))
|
||||
(set-elts-hash set))
|
||||
elements))
|
||||
|
||||
|
||||
; Print the set
|
||||
(defmethod print-object ((set set) stream)
|
||||
(if *print-readably*
|
||||
(call-next-method)
|
||||
(format stream "~<{~;~@{~W ~:_~}~;}~:>" (set-elements set))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; DEPTH-FIRST SEARCH
|
||||
|
||||
; Return a depth-first-ordered list of the nodes in a directed graph.
|
||||
; The graph may contain cycles, so a general depth-first search is used.
|
||||
; start is the start node.
|
||||
; successors is a function that takes a node and returns a list of that
|
||||
; node's successors.
|
||||
; test is a function that takes two nodes and returns true if they are
|
||||
; the same node. test should be either #'eq, #'eql, or #'equal
|
||||
; because it is used as a test function in a hash table.
|
||||
(defun depth-first-search (test successors start)
|
||||
(let ((visited-nodes (make-set test))
|
||||
(dfs-list nil))
|
||||
(labels
|
||||
((visit (node)
|
||||
(set-add visited-nodes node)
|
||||
(dolist (successor (funcall successors node))
|
||||
(unless (set-member visited-nodes successor)
|
||||
(visit successor)))
|
||||
(push node dfs-list)))
|
||||
(visit start)
|
||||
dfs-list)))
|
||||
|
|
@ -0,0 +1,64 @@
|
|||
.title1 {font-family: "Times New Roman", Times, serif; font-size: 36pt; font-weight: bold; color: #000000; white-space: nowrap}
|
||||
|
||||
.title2 {font-family: "Times New Roman", Times, serif; font-size: 18pt; font-weight: bold; color: #000000; white-space: nowrap}
|
||||
|
||||
.top-title {color: #009900}
|
||||
|
||||
.sub {font-size: 50%}
|
||||
|
||||
.sub-num {font-size: smaller; font-style: normal}
|
||||
|
||||
.syntax {margin-left: 0.5in}
|
||||
|
||||
.issue {color: #FF0000}
|
||||
|
||||
|
||||
|
||||
.grammar-rule {margin-left: 18pt; margin-top: 6pt; margin-bottom: 6pt}
|
||||
|
||||
.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}
|
||||
|
||||
|
||||
|
||||
.symbol {font-family: "Symbol"}
|
||||
|
||||
VAR {font-family: Georgia, Palatino, "Times New Roman", Times, serif; font-weight: normal; font-style: italic}
|
||||
|
||||
CODE {font-family: "Courier New", Courier, mono; color: #0000FF}
|
||||
|
||||
PRE {font-family: "Courier New", Courier, mono; color: #0000FF; margin-left: 0.5in}
|
||||
|
||||
.control {font-family: "Times New Roman", Times, serif; font-weight: normal; color: #000099}
|
||||
|
||||
.terminal {font-family: Georgia, Palatino, "Times New Roman", Times, serif; font-weight: bold; color: #009999}
|
||||
|
||||
.terminal-keyword {font-weight: bold}
|
||||
|
||||
.nonterminal {color: #009900}
|
||||
|
||||
.nonterminal-attribute {font-style: normal}
|
||||
|
||||
.nonterminal-argument {font-style: normal}
|
||||
|
||||
.semantic-keyword {font-family: "Times New Roman", Times, serif; font-weight: bold}
|
||||
|
||||
.type-expression {font-family: "Times New Roman", Times, serif; color: #CC0000}
|
||||
|
||||
.type-name {font-family: "Times New Roman", Times, serif; font-variant: small-caps; color: #CC0000}
|
||||
|
||||
.field-name {font-family: Arial, Helvetica, sans-serif; color: #FF0000}
|
||||
|
||||
.global-variable {font-family: "Times New Roman", Times, serif; color: #006600}
|
||||
|
||||
.local-variable {font-family: "Times New Roman", Times, serif; color: #009900}
|
||||
|
||||
.action-name {font-family: "Zapf Chancery", "Comic Sans MS", Script, serif; color: #660066}
|
||||
|
||||
Загрузка…
Ссылка в новой задаче