зеркало из https://github.com/mozilla/pjs.git
Switchover to Algol-style semantics
This commit is contained in:
waldemar%netscape.com
Родитель
95b05408c4
Коммит
dacc51531a
Разница между файлами не показана из-за своего большого размера
Загрузить разницу
Разница между файлами не показана из-за своего большого размера
Загрузить разницу
|
|
@ -152,8 +152,9 @@
|
|||
;;; the values returned by the rhs's last grammar symbol's actions, in order of the
|
||||
;;; actions of that grammar symbol.
|
||||
;;; Function f returns one value, which is the result of this action.
|
||||
(defstruct (action (:constructor make-action (expr))
|
||||
(defstruct (action (:constructor make-action (type expr))
|
||||
(:predicate action?))
|
||||
(type nil :read-only t) ;The unparsed type of the action's result
|
||||
(expr nil :read-only t) ;The unparsed source expression that defines the action
|
||||
(code nil)) ;The generated lisp source code that performs the action
|
||||
|
||||
|
|
@ -261,9 +262,9 @@
|
|||
|
||||
; Emit a markup paragraph for the left-hand-side of a general production.
|
||||
(defun depict-general-production-lhs (markup-stream lhs-general-nonterminal)
|
||||
(depict-paragraph (markup-stream ':grammar-lhs)
|
||||
(depict-paragraph (markup-stream :grammar-lhs)
|
||||
(depict-general-nonterminal markup-stream lhs-general-nonterminal :definition)
|
||||
(depict markup-stream " " ':derives-10)))
|
||||
(depict markup-stream " " :derives-10)))
|
||||
|
||||
|
||||
; Emit markup for a production right-hand-side component.
|
||||
|
|
@ -280,10 +281,10 @@
|
|||
; first is true if this is the first production in a rule.
|
||||
; last is true if this is the last production in a rule.
|
||||
(defun depict-general-production-rhs (markup-stream general-production first last)
|
||||
(depict-paragraph (markup-stream (if last ':grammar-rhs-last ':grammar-rhs))
|
||||
(depict-paragraph (markup-stream (if last :grammar-rhs-last :grammar-rhs))
|
||||
(if first
|
||||
(depict markup-stream ':tab3)
|
||||
(depict markup-stream "|" ':tab2))
|
||||
(depict markup-stream :tab3)
|
||||
(depict markup-stream "|" :tab2))
|
||||
(let ((rhs-components (general-production-rhs-components general-production)))
|
||||
(depict-list markup-stream
|
||||
#'depict-production-rhs-component
|
||||
|
|
@ -301,7 +302,7 @@
|
|||
(let ((lhs (general-production-lhs general-production))
|
||||
(rhs-components (general-production-rhs-components general-production)))
|
||||
(depict-general-nonterminal markup-stream lhs link)
|
||||
(depict markup-stream " " ':derives-10)
|
||||
(depict markup-stream " " :derives-10)
|
||||
(if rhs-components
|
||||
(let ((counts-hash (make-hash-table :test *grammar-symbol-=*)))
|
||||
(when symbols-with-subscripts
|
||||
|
|
@ -326,7 +327,7 @@
|
|||
(setq subscript (incf (gethash symbol counts-hash))))))
|
||||
(depict-space markup-stream)
|
||||
(depict-production-rhs-component markup-stream production-rhs-component subscript))))
|
||||
(depict markup-stream " " ':left-angle-quote "empty" :right-angle-quote))))
|
||||
(depict markup-stream " " :left-angle-quote "empty" :right-angle-quote))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
|
|
@ -349,7 +350,6 @@
|
|||
(actions nil :type list) ;List of (action-symbol . action-or-nil) in the same order as the action-symbols
|
||||
; ; are listed in the grammar's action-signatures hash table for this lhs
|
||||
(n-action-args nil :type (or null integer)) ;Total size of the action-signatures of all grammar symbols in the rhs
|
||||
(evaluator-code nil) ;The lisp evaluator's source code
|
||||
(evaluator nil :type (or null function))) ;The lisp evaluator of the action
|
||||
|
||||
|
||||
|
|
@ -474,7 +474,7 @@
|
|||
(rule-highlight (and (endp (rest production-runs))
|
||||
(check-highlight (first (first production-runs)) highlights markup-stream))))
|
||||
(depict-block-style (markup-stream rule-highlight t)
|
||||
(depict-block-style (markup-stream ':grammar-rule)
|
||||
(depict-block-style (markup-stream :grammar-rule)
|
||||
(if (rest general-productions)
|
||||
(progn
|
||||
(depict-general-production-lhs markup-stream (general-rule-lhs general-rule))
|
||||
|
|
@ -482,7 +482,7 @@
|
|||
(depict-block-style (markup-stream (check-highlight (first production-run) highlights markup-stream) t)
|
||||
(dolist (p (rest production-run))
|
||||
(apply #'depict-general-production-rhs markup-stream p)))))
|
||||
(depict-paragraph (markup-stream ':grammar-lhs-last)
|
||||
(depict-paragraph (markup-stream :grammar-lhs-last)
|
||||
(depict-general-production markup-stream (first general-productions) :definition))))))))
|
||||
|
||||
|
||||
|
|
@ -910,13 +910,13 @@
|
|||
(let ((parameter (first parameters))
|
||||
(subtree (make-parameter-subtree grammar (rest parameters) general-production)))
|
||||
(if (nonterminal-argument? parameter)
|
||||
(list ':argument parameter subtree)
|
||||
(list ':attributes nil (cons parameter subtree)))))
|
||||
(list :argument parameter subtree)
|
||||
(list :attributes nil (cons parameter subtree)))))
|
||||
((production? general-production)
|
||||
(list ':rule (grammar-rule grammar (production-lhs general-production))))
|
||||
(list :rule (grammar-rule grammar (production-lhs general-production))))
|
||||
(t
|
||||
(assert-true (generic-production? general-production))
|
||||
(list ':rule (make-generic-rule (list general-production))))))
|
||||
(list :rule (make-generic-rule (list general-production))))))
|
||||
|
||||
|
||||
; Create and return an initial parameter tree for the general-production.
|
||||
|
|
@ -939,16 +939,16 @@
|
|||
(lhs (general-rule-lhs general-rule))
|
||||
(new-lhs (general-grammar-symbol-substitute attribute argument lhs)))
|
||||
(assert-true (generic-rule? general-rule))
|
||||
(list ':rule
|
||||
(list :rule
|
||||
(if (generic-nonterminal? new-lhs)
|
||||
(generic-rule-substitute grammar attribute argument general-rule)
|
||||
(grammar-rule grammar new-lhs)))))
|
||||
(:argument
|
||||
(list ':argument
|
||||
(list :argument
|
||||
(second subtree)
|
||||
(substitute-argument-with attribute (third subtree))))
|
||||
(:attributes
|
||||
(list ':attributes
|
||||
(list :attributes
|
||||
(second subtree)
|
||||
(mapcar #'(lambda (argument-subtree-binding)
|
||||
(cons (car argument-subtree-binding)
|
||||
|
|
@ -958,7 +958,7 @@
|
|||
(create-attribute-subtree-binding (attribute)
|
||||
(cons attribute (substitute-argument-with attribute argument-subtree))))
|
||||
|
||||
(setf (first parameter-subtree) ':attributes)
|
||||
(setf (first parameter-subtree) :attributes)
|
||||
(setf (cddr parameter-subtree)
|
||||
(mapcar #'create-attribute-subtree-binding
|
||||
(grammar-parametrization-lookup-argument grammar argument))))))
|
||||
|
|
@ -1234,12 +1234,12 @@
|
|||
(pos 0))
|
||||
(dolist (component-source production-rhs-source)
|
||||
(cond
|
||||
((and (consp component-source) (eq (first component-source) ':-))
|
||||
((and (consp component-source) (eq (first component-source) :-))
|
||||
(let ((lookaheads (rest component-source)))
|
||||
(push
|
||||
(make-lookahead-constraint pos (assert-non-null lookaheads) lookaheads)
|
||||
constraints)))
|
||||
((and (consp component-source) (eq (first component-source) ':--))
|
||||
((and (consp component-source) (eq (first component-source) :--))
|
||||
(let ((lookaheads (rest component-source)))
|
||||
(push
|
||||
(make-lookahead-constraint pos (assert-non-null (rest lookaheads)) (assert-non-null (first lookaheads)))
|
||||
|
|
@ -1574,7 +1574,7 @@
|
|||
|
||||
; Emit markup paragraphs for the grammar.
|
||||
(defun depict-grammar (markup-stream grammar)
|
||||
(depict-paragraph (markup-stream ':body-text)
|
||||
(depict-paragraph (markup-stream :body-text)
|
||||
(depict markup-stream "Start nonterminal: ")
|
||||
(depict-general-nonterminal markup-stream (gramar-user-start-symbol grammar) :reference))
|
||||
(dolist (nonterminal (grammar-nonterminals-list grammar))
|
||||
|
|
|
|||
|
|
@ -90,25 +90,25 @@
|
|||
(defun depict-terminal (markup-stream terminal &optional subscript)
|
||||
(cond
|
||||
((characterp terminal)
|
||||
(depict-char-style (markup-stream ':character-literal)
|
||||
(depict-char-style (markup-stream :character-literal)
|
||||
(depict-character markup-stream terminal)
|
||||
(when subscript
|
||||
(depict-char-style (markup-stream ':plain-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-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-char-style (markup-stream :plain-subscript)
|
||||
(depict-integer markup-stream subscript))))
|
||||
(progn
|
||||
(depict-char-style (markup-stream ':terminal-keyword)
|
||||
(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-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))))
|
||||
|
||||
|
|
@ -131,8 +131,8 @@
|
|||
|
||||
|
||||
(defun depict-nonterminal-attribute (markup-stream attribute)
|
||||
(depict-char-style (markup-stream ':nonterminal)
|
||||
(depict-char-style (markup-stream ':nonterminal-attribute)
|
||||
(depict-char-style (markup-stream :nonterminal)
|
||||
(depict-char-style (markup-stream :nonterminal-attribute)
|
||||
(depict markup-stream (symbol-lower-mixed-case-name attribute)))))
|
||||
|
||||
|
||||
|
|
@ -148,7 +148,7 @@
|
|||
: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-char-style (markup-stream :nonterminal-argument)
|
||||
(let ((argument (symbol-abbreviation argument)))
|
||||
(depict markup-stream
|
||||
(if (member argument *special-nonterminal-arguments*)
|
||||
|
|
@ -156,7 +156,7 @@
|
|||
(symbol-upper-mixed-case-name argument))))))
|
||||
|
||||
(defun depict-nonterminal-argument (markup-stream argument)
|
||||
(depict-char-style (markup-stream ':nonterminal)
|
||||
(depict-char-style (markup-stream :nonterminal)
|
||||
(depict-nonterminal-argument-symbol markup-stream argument)))
|
||||
|
||||
|
||||
|
|
@ -287,18 +287,18 @@
|
|||
|
||||
(depict-nonterminal-parameter (markup-stream parameter)
|
||||
(if (nonterminal-attribute? parameter)
|
||||
(depict-char-style (markup-stream ':nonterminal-attribute)
|
||||
(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 (markup-stream symbol parameters)
|
||||
(depict-nonterminal-name markup-stream symbol)
|
||||
(depict-char-style (markup-stream ':superscript)
|
||||
(depict-char-style (markup-stream :superscript)
|
||||
(depict-list markup-stream #'depict-nonterminal-parameter parameters
|
||||
:separator ",")))
|
||||
|
||||
(depict-general (markup-stream)
|
||||
(depict-char-style (markup-stream ':nonterminal)
|
||||
(depict-char-style (markup-stream :nonterminal)
|
||||
(cond
|
||||
((keywordp general-nonterminal)
|
||||
(depict-nonterminal-name markup-stream general-nonterminal))
|
||||
|
|
@ -312,7 +312,7 @@
|
|||
(generic-nonterminal-parameters general-nonterminal)))
|
||||
(t (error "Bad nonterminal ~S" general-nonterminal)))
|
||||
(when subscript
|
||||
(depict-char-style (markup-stream ':plain-subscript)
|
||||
(depict-char-style (markup-stream :plain-subscript)
|
||||
(depict-integer markup-stream subscript))))))
|
||||
|
||||
(if (or (eq link :definition)
|
||||
|
|
|
|||
|
|
@ -341,7 +341,7 @@
|
|||
(if (consp html-source)
|
||||
(let ((tag (first html-source))
|
||||
(contents (rest html-source)))
|
||||
(if (and (consp tag) (eq (first tag) ':nest))
|
||||
(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)))
|
||||
|
|
@ -397,19 +397,23 @@
|
|||
|
||||
;Symbols (-10 suffix means 10-point, etc.)
|
||||
((:bullet 1) (:script "document.write(U_bull)")) ;#x2022
|
||||
((:minus 1) "-")
|
||||
((:not-equal 1) (:script "document.write(U_ne)")) ;#x2260
|
||||
((:less-or-equal 1) (:script "document.write(U_le)")) ;#x2264
|
||||
((:greater-or-equal 1) (:script "document.write(U_ge)")) ;#x2265
|
||||
((:infinity 1) (:script "document.write(U_infin)")) ;#x221E
|
||||
((:minus 1) #x2013)
|
||||
((:m-dash 2) #x2014)
|
||||
((:left-single-quote 1) #x2018)
|
||||
((:right-single-quote 1) #x2019)
|
||||
((:apostrophe 1) #x2019)
|
||||
((:left-double-quote 1) #x201C)
|
||||
((:right-double-quote 1) #x201D)
|
||||
((:left-angle-quote 1) #x00AB)
|
||||
((:right-angle-quote 1) #x00BB)
|
||||
((:for-all-10 1) (:script "document.write(U_forall)")) ;#x2200
|
||||
((:exists-10 1) (:script "document.write(U_exist)")) ;#x2203
|
||||
((:bottom-10 1) (:script "document.write(U_perp)")) ;#x22A5
|
||||
((:vector-assign-10 1) (:script "document.write(U_larr)")) ;#x2190
|
||||
((:assign-10 1) (:script "document.write(U_larr)")) ;#x2190
|
||||
((:up-arrow-10 1) (:script "document.write(U_uarr)")) ;#x2191
|
||||
((:function-arrow-10 2) (:script "document.write(U_rarr)")) ;#x2192
|
||||
((:cartesian-product-10 2) (:script "document.write(U_times)")) ;#x00D7
|
||||
|
|
@ -420,9 +424,14 @@
|
|||
((:union-10 1) (:script "document.write(U_cup)")) ;#x222A
|
||||
((:member-10 2) (:script "document.write(U_isin)")) ;#x2208
|
||||
((:not-member-10 2) (:script "document.write(U_notin)")) ;#x2209
|
||||
((:label-assign-10 2) (:script "document.write(U_lArr)")) ;#x21D0
|
||||
((:derives-10 2) (:script "document.write(U_rArr)")) ;#x21D2
|
||||
((:left-triangle-bracket-10 1) (:script "document.write(U_lang)")) ;#x2329
|
||||
((:left-ceiling-10 1) (:script "document.write(U_lceil)")) ;#x2308
|
||||
((:left-floor-10 1) (:script "document.write(U_lfloor)")) ;#x230A
|
||||
((:right-triangle-bracket-10 1) (:script "document.write(U_rang)")) ;#x232A
|
||||
((:right-ceiling-10 1) (:script "document.write(U_rceil)")) ;#x2309
|
||||
((:right-floor-10 1) (:script "document.write(U_rfloor)")) ;#x230B
|
||||
|
||||
((:alpha 1) (:script "document.write(U_alpha)"))
|
||||
((:beta 1) (:script "document.write(U_beta)"))
|
||||
|
|
@ -480,6 +489,7 @@
|
|||
(:type-expression (span (class "type-expression")))
|
||||
(:type-name (span (class "type-name")))
|
||||
(:field-name (span (class "field-name")))
|
||||
(:tag-name (span (class "tag-name")))
|
||||
(:global-variable (span (class "global-variable")))
|
||||
(:local-variable (span (class "local-variable")))
|
||||
(:action-name (span (class "action-name")))
|
||||
|
|
@ -504,6 +514,8 @@
|
|||
((:vector-append 2) :circle-plus-10)
|
||||
((:tuple-begin 1) (b :left-triangle-bracket-10))
|
||||
((:tuple-end 1) (b :right-triangle-bracket-10))
|
||||
((:record-begin 1) (b (:script "document.write(U_lang+U_lang)")))
|
||||
((:record-end 1) (b (:script "document.write(U_rang+U_rang)")))
|
||||
((:true 4) (:global-variable "true"))
|
||||
((:false 5) (:global-variable "false"))
|
||||
((:unique 6) (:semantic-keyword "unique"))
|
||||
|
|
|
|||
|
|
@ -58,22 +58,37 @@
|
|||
($digit-value integer digit-value digit-char-36)))
|
||||
|
||||
(rule :$next-input-element
|
||||
((input-element input-element))
|
||||
((lex input-element))
|
||||
(production :$next-input-element ($unit (:next-input-element unit)) $next-input-element-unit
|
||||
(input-element (input-element :next-input-element)))
|
||||
(lex (lex :next-input-element)))
|
||||
(production :$next-input-element ($re (:next-input-element re)) $next-input-element-re
|
||||
(input-element (input-element :next-input-element)))
|
||||
(lex (lex :next-input-element)))
|
||||
(production :$next-input-element ($non-re (:next-input-element div)) $next-input-element-non-re
|
||||
(input-element (input-element :next-input-element))))
|
||||
(lex (lex :next-input-element))))
|
||||
|
||||
(%text nil "The start symbols are: "
|
||||
(:grammar-symbol (:next-input-element unit)) " if the previous input element was a number; "
|
||||
(:grammar-symbol (:next-input-element re)) " if the previous input-element was not a number and a "
|
||||
(:grammar-symbol (:next-input-element re)) " if the previous input element was not a number and a "
|
||||
(:character-literal #\/) " should be interpreted as a regular expression; and "
|
||||
(:grammar-symbol (:next-input-element div)) " if the previous input-element was not a number and a "
|
||||
(:grammar-symbol (:next-input-element div)) " if the previous input element was not a number and a "
|
||||
(:character-literal #\/) " should be interpreted as a division or division-assignment operator.")
|
||||
|
||||
(deftype semantic-exception (oneof syntax-error))
|
||||
(deftag line-break)
|
||||
(deftag end-of-input)
|
||||
|
||||
(deftag keyword (name string))
|
||||
(deftag punctuator (name string))
|
||||
(deftag identifier (name string))
|
||||
(deftag number (value float64))
|
||||
(deftag string (value string))
|
||||
(deftag regular-expression (body string) (flags string))
|
||||
|
||||
(deftype token (tag keyword punctuator identifier number string regular-expression))
|
||||
(deftype input-element (union (tag line-break end-of-input) token))
|
||||
|
||||
|
||||
(deftag syntax-error)
|
||||
(deftype semantic-exception (tag syntax-error))
|
||||
|
||||
(%section "Unicode Character Classes")
|
||||
(%charclass :unicode-character)
|
||||
|
|
@ -133,74 +148,59 @@
|
|||
(grammar-argument :nu_2 re div)
|
||||
|
||||
(rule (:next-input-element :nu)
|
||||
((input-element input-element))
|
||||
((lex input-element))
|
||||
(production (:next-input-element re) (:white-space (:input-element re)) next-input-element-re
|
||||
(input-element (input-element :input-element)))
|
||||
(lex (lex :input-element)))
|
||||
(production (:next-input-element div) (:white-space (:input-element div)) next-input-element-div
|
||||
(input-element (input-element :input-element)))
|
||||
(lex (lex :input-element)))
|
||||
(production (:next-input-element unit) ((:- :continuing-identifier-character #\\) :white-space (:input-element div)) next-input-element-unit-normal
|
||||
(input-element (input-element :input-element)))
|
||||
(lex (lex :input-element)))
|
||||
(production (:next-input-element unit) ((:- #\_) :identifier-name) next-input-element-unit-name
|
||||
(input-element (oneof string (name :identifier-name))))
|
||||
(lex (tag string (lex-name :identifier-name))))
|
||||
(production (:next-input-element unit) (#\_ :identifier-name) next-input-element-unit-underscore-name
|
||||
(input-element (oneof string (name :identifier-name)))))
|
||||
(lex (tag string (lex-name :identifier-name)))))
|
||||
|
||||
(%print-actions)
|
||||
|
||||
(rule (:input-element :nu_2)
|
||||
((input-element input-element))
|
||||
((lex input-element))
|
||||
(production (:input-element :nu_2) (:line-breaks) input-element-line-breaks
|
||||
(input-element (oneof line-break)))
|
||||
(lex line-break))
|
||||
(production (:input-element :nu_2) (:identifier-or-keyword) input-element-identifier-or-keyword
|
||||
(input-element (input-element :identifier-or-keyword)))
|
||||
(lex (lex :identifier-or-keyword)))
|
||||
(production (:input-element :nu_2) (:punctuator) input-element-punctuator
|
||||
(input-element (oneof punctuator (punctuator :punctuator))))
|
||||
(lex (lex :punctuator)))
|
||||
(production (:input-element div) (:division-punctuator) input-element-division-punctuator
|
||||
(input-element (oneof punctuator (punctuator :division-punctuator))))
|
||||
(lex (lex :division-punctuator)))
|
||||
(production (:input-element :nu_2) (:numeric-literal) input-element-numeric-literal
|
||||
(input-element (oneof number (float64-value :numeric-literal))))
|
||||
(lex (lex :numeric-literal)))
|
||||
(production (:input-element :nu_2) (:string-literal) input-element-string-literal
|
||||
(input-element (oneof string (string-value :string-literal))))
|
||||
(lex (lex :string-literal)))
|
||||
(production (:input-element re) (:reg-exp-literal) input-element-reg-exp-literal
|
||||
(input-element (oneof regular-expression (r-e-value :reg-exp-literal))))
|
||||
(lex (lex :reg-exp-literal)))
|
||||
(production (:input-element :nu_2) (:end-of-input) input-element-end
|
||||
(input-element (oneof end))))
|
||||
(lex end-of-input)))
|
||||
|
||||
(production :end-of-input ($end) end-of-input-end)
|
||||
(production :end-of-input (:line-comment $end) end-of-input-line-comment)
|
||||
|
||||
(deftype reg-exp (tuple (re-body string)
|
||||
(re-flags string)))
|
||||
|
||||
(deftype quantity (tuple (amount float64)
|
||||
(unit string)))
|
||||
|
||||
(deftype input-element (oneof line-break
|
||||
(identifier string)
|
||||
(keyword string)
|
||||
(punctuator string)
|
||||
(number float64)
|
||||
(string string)
|
||||
(regular-expression reg-exp)
|
||||
end))
|
||||
(%print-actions)
|
||||
|
||||
(%section "Keywords and identifiers")
|
||||
|
||||
(rule :identifier-name
|
||||
((name string) (contains-escapes boolean))
|
||||
((lex-name string) (contains-escapes boolean))
|
||||
(production :identifier-name (:initial-identifier-character-or-escape) identifier-name-initial
|
||||
(name (vector (character-value :initial-identifier-character-or-escape)))
|
||||
(lex-name (vector (lex-char :initial-identifier-character-or-escape)))
|
||||
(contains-escapes (contains-escapes :initial-identifier-character-or-escape)))
|
||||
(production :identifier-name (:null-escapes :initial-identifier-character-or-escape) identifier-name-initial-null-escapes
|
||||
(name (vector (character-value :initial-identifier-character-or-escape)))
|
||||
(lex-name (vector (lex-char :initial-identifier-character-or-escape)))
|
||||
(contains-escapes true))
|
||||
(production :identifier-name (:identifier-name :continuing-identifier-character-or-escape) identifier-name-continuing
|
||||
(name (append (name :identifier-name) (vector (character-value :continuing-identifier-character-or-escape))))
|
||||
(lex-name (append (lex-name :identifier-name) (vector (lex-char :continuing-identifier-character-or-escape))))
|
||||
(contains-escapes (or (contains-escapes :identifier-name)
|
||||
(contains-escapes :continuing-identifier-character-or-escape))))
|
||||
(production :identifier-name (:identifier-name :null-escape) identifier-name-null-escape
|
||||
(name (name :identifier-name))
|
||||
(lex-name (lex-name :identifier-name))
|
||||
(contains-escapes true)))
|
||||
|
||||
(production :null-escapes (:null-escape) null-escapes-one)
|
||||
|
|
@ -209,34 +209,34 @@
|
|||
(production :null-escape (#\\ #\_) null-escape-underscore)
|
||||
|
||||
(rule :initial-identifier-character-or-escape
|
||||
((character-value character) (contains-escapes boolean))
|
||||
((lex-char character) (contains-escapes boolean))
|
||||
(production :initial-identifier-character-or-escape (:initial-identifier-character) initial-identifier-character-or-escape-ordinary
|
||||
(character-value ($default-action :initial-identifier-character))
|
||||
(lex-char ($default-action :initial-identifier-character))
|
||||
(contains-escapes false))
|
||||
(production :initial-identifier-character-or-escape (#\\ :hex-escape) initial-identifier-character-or-escape-escape
|
||||
(character-value (if (is-initial-identifier-character (character-value :hex-escape))
|
||||
(character-value :hex-escape)
|
||||
(throw (oneof syntax-error))))
|
||||
(lex-char (begin (if (is-initial-identifier-character (lex-char :hex-escape))
|
||||
(return (lex-char :hex-escape))
|
||||
(throw syntax-error))))
|
||||
(contains-escapes true)))
|
||||
|
||||
(%charclass :initial-identifier-character)
|
||||
|
||||
(rule :continuing-identifier-character-or-escape
|
||||
((character-value character) (contains-escapes boolean))
|
||||
((lex-char character) (contains-escapes boolean))
|
||||
(production :continuing-identifier-character-or-escape (:continuing-identifier-character) continuing-identifier-character-or-escape-ordinary
|
||||
(character-value ($default-action :continuing-identifier-character))
|
||||
(lex-char ($default-action :continuing-identifier-character))
|
||||
(contains-escapes false))
|
||||
(production :continuing-identifier-character-or-escape (#\\ :hex-escape) continuing-identifier-character-or-escape-escape
|
||||
(character-value (if (is-continuing-identifier-character (character-value :hex-escape))
|
||||
(character-value :hex-escape)
|
||||
(throw (oneof syntax-error))))
|
||||
(lex-char (begin (if (is-continuing-identifier-character (lex-char :hex-escape))
|
||||
(return (lex-char :hex-escape))
|
||||
(throw syntax-error))))
|
||||
(contains-escapes true)))
|
||||
|
||||
(%charclass :continuing-identifier-character)
|
||||
(%print-actions)
|
||||
|
||||
(define reserved-words (vector string)
|
||||
(vector "abstract" "break" "case" "catch" "class" "const" "continue" "debugger" "default" "delete" "do" "else" "enum"
|
||||
(vector "abstract" "as" "break" "case" "catch" "class" "const" "continue" "debugger" "default" "delete" "do" "else" "enum"
|
||||
"export" "extends" "false" "final" "finally" "for" "function" "goto" "if" "implements" "import" "in"
|
||||
"instanceof" "interface" "namespace" "native" "new" "null" "package" "private" "protected" "public" "return" "static" "super"
|
||||
"switch" "synchronized" "this" "throw" "throws" "transient" "true" "try" "typeof" "use" "var" "volatile" "while" "with"))
|
||||
|
|
@ -246,165 +246,159 @@
|
|||
(append reserved-words non-reserved-words))
|
||||
|
||||
(define (member (id string) (list (vector string))) boolean
|
||||
(if (empty list)
|
||||
false
|
||||
(if (string= id (nth list 0))
|
||||
true
|
||||
(member id (subseq list 1)))))
|
||||
(rwhen (empty list)
|
||||
(return false))
|
||||
(rwhen (= id (nth list 0) string)
|
||||
(return true))
|
||||
(return (member id (subseq list 1))))
|
||||
|
||||
(rule :identifier-or-keyword
|
||||
((input-element input-element))
|
||||
((lex input-element))
|
||||
(production :identifier-or-keyword (:identifier-name) identifier-or-keyword-identifier-name
|
||||
(input-element (let ((id string (name :identifier-name)))
|
||||
(if (and (member id keywords) (not (contains-escapes :identifier-name)))
|
||||
(oneof keyword id)
|
||||
(oneof identifier id))))))
|
||||
(lex (begin
|
||||
(const id string (lex-name :identifier-name))
|
||||
(if (and (member id keywords) (not (contains-escapes :identifier-name)))
|
||||
(return (tag keyword id))
|
||||
(return (tag identifier id)))))))
|
||||
(%print-actions)
|
||||
|
||||
(%section "Punctuators")
|
||||
|
||||
(rule :punctuator ((punctuator string))
|
||||
(production :punctuator (#\!) punctuator-not (punctuator "!"))
|
||||
(production :punctuator (#\! #\=) punctuator-not-equal (punctuator "!="))
|
||||
(production :punctuator (#\! #\= #\=) punctuator-not-identical (punctuator "!=="))
|
||||
(production :punctuator (#\#) punctuator-hash (punctuator "#"))
|
||||
(production :punctuator (#\%) punctuator-modulo (punctuator "%"))
|
||||
(production :punctuator (#\% #\=) punctuator-modulo-equals (punctuator "%="))
|
||||
(production :punctuator (#\&) punctuator-and (punctuator "&"))
|
||||
(production :punctuator (#\& #\&) punctuator-logical-and (punctuator "&&"))
|
||||
(production :punctuator (#\& #\& #\=) punctuator-logical-and-equals (punctuator "&&="))
|
||||
(production :punctuator (#\& #\=) punctuator-and-equals (punctuator "&="))
|
||||
(production :punctuator (#\() punctuator-open-parenthesis (punctuator "("))
|
||||
(production :punctuator (#\)) punctuator-close-parenthesis (punctuator ")"))
|
||||
(production :punctuator (#\*) punctuator-times (punctuator "*"))
|
||||
(production :punctuator (#\* #\=) punctuator-times-equals (punctuator "*="))
|
||||
(production :punctuator (#\+) punctuator-plus (punctuator "+"))
|
||||
(production :punctuator (#\+ #\+) punctuator-increment (punctuator "++"))
|
||||
(production :punctuator (#\+ #\=) punctuator-plus-equals (punctuator "+="))
|
||||
(production :punctuator (#\,) punctuator-comma (punctuator ","))
|
||||
(production :punctuator (#\-) punctuator-minus (punctuator "-"))
|
||||
(production :punctuator (#\- #\-) punctuator-decrement (punctuator "--"))
|
||||
(production :punctuator (#\- #\=) punctuator-minus-equals (punctuator "-="))
|
||||
(production :punctuator (#\- #\>) punctuator-arrow (punctuator "->"))
|
||||
(production :punctuator (#\.) punctuator-dot (punctuator "."))
|
||||
(production :punctuator (#\. #\.) punctuator-double-dot (punctuator ".."))
|
||||
(production :punctuator (#\. #\. #\.) punctuator-triple-dot (punctuator "..."))
|
||||
(production :punctuator (#\:) punctuator-colon (punctuator ":"))
|
||||
(production :punctuator (#\: #\:) punctuator-namespace (punctuator "::"))
|
||||
(production :punctuator (#\;) punctuator-semicolon (punctuator ";"))
|
||||
(production :punctuator (#\<) punctuator-less-than (punctuator "<"))
|
||||
(production :punctuator (#\< #\<) punctuator-left-shift (punctuator "<<"))
|
||||
(production :punctuator (#\< #\< #\=) punctuator-left-shift-equals (punctuator "<<="))
|
||||
(production :punctuator (#\< #\=) punctuator-less-than-or-equal (punctuator "<="))
|
||||
(production :punctuator (#\=) punctuator-assignment (punctuator "="))
|
||||
(production :punctuator (#\= #\=) punctuator-equal (punctuator "=="))
|
||||
(production :punctuator (#\= #\= #\=) punctuator-identical (punctuator "==="))
|
||||
(production :punctuator (#\>) punctuator-greater-than (punctuator ">"))
|
||||
(production :punctuator (#\> #\=) punctuator-greater-than-or-equal (punctuator ">="))
|
||||
(production :punctuator (#\> #\>) punctuator-right-shift (punctuator ">>"))
|
||||
(production :punctuator (#\> #\> #\=) punctuator-right-shift-equals (punctuator ">>="))
|
||||
(production :punctuator (#\> #\> #\>) punctuator-logical-right-shift (punctuator ">>>"))
|
||||
(production :punctuator (#\> #\> #\> #\=) punctuator-logical-right-shift-equals (punctuator ">>>="))
|
||||
(production :punctuator (#\?) punctuator-question (punctuator "?"))
|
||||
(production :punctuator (#\@) punctuator-at (punctuator "@"))
|
||||
(production :punctuator (#\[) punctuator-open-bracket (punctuator "["))
|
||||
(production :punctuator (#\]) punctuator-close-bracket (punctuator "]"))
|
||||
(production :punctuator (#\^) punctuator-xor (punctuator "^"))
|
||||
(production :punctuator (#\^ #\=) punctuator-xor-equals (punctuator "^="))
|
||||
(production :punctuator (#\^ #\^) punctuator-logical-xor (punctuator "^^"))
|
||||
(production :punctuator (#\^ #\^ #\=) punctuator-logical-xor-equals (punctuator "^^="))
|
||||
(production :punctuator (#\{) punctuator-open-brace (punctuator "{"))
|
||||
(production :punctuator (#\|) punctuator-or (punctuator "|"))
|
||||
(production :punctuator (#\| #\=) punctuator-or-equals (punctuator "|="))
|
||||
(production :punctuator (#\| #\|) punctuator-logical-or (punctuator "||"))
|
||||
(production :punctuator (#\| #\| #\=) punctuator-logical-or-equals (punctuator "||="))
|
||||
(production :punctuator (#\}) punctuator-close-brace (punctuator "}"))
|
||||
(production :punctuator (#\~) punctuator-complement (punctuator "~")))
|
||||
(rule :punctuator ((lex token))
|
||||
(production :punctuator (#\!) punctuator-not (lex (tag punctuator "!")))
|
||||
(production :punctuator (#\! #\=) punctuator-not-equal (lex (tag punctuator "!=")))
|
||||
(production :punctuator (#\! #\= #\=) punctuator-not-identical (lex (tag punctuator "!==")))
|
||||
(production :punctuator (#\#) punctuator-hash (lex (tag punctuator "#")))
|
||||
(production :punctuator (#\%) punctuator-modulo (lex (tag punctuator "%")))
|
||||
(production :punctuator (#\% #\=) punctuator-modulo-equals (lex (tag punctuator "%=")))
|
||||
(production :punctuator (#\&) punctuator-and (lex (tag punctuator "&")))
|
||||
(production :punctuator (#\& #\&) punctuator-logical-and (lex (tag punctuator "&&")))
|
||||
(production :punctuator (#\& #\& #\=) punctuator-logical-and-equals (lex (tag punctuator "&&=")))
|
||||
(production :punctuator (#\& #\=) punctuator-and-equals (lex (tag punctuator "&=")))
|
||||
(production :punctuator (#\() punctuator-open-parenthesis (lex (tag punctuator "(")))
|
||||
(production :punctuator (#\)) punctuator-close-parenthesis (lex (tag punctuator ")")))
|
||||
(production :punctuator (#\*) punctuator-times (lex (tag punctuator "*")))
|
||||
(production :punctuator (#\* #\=) punctuator-times-equals (lex (tag punctuator "*=")))
|
||||
(production :punctuator (#\+) punctuator-plus (lex (tag punctuator "+")))
|
||||
(production :punctuator (#\+ #\+) punctuator-increment (lex (tag punctuator "++")))
|
||||
(production :punctuator (#\+ #\=) punctuator-plus-equals (lex (tag punctuator "+=")))
|
||||
(production :punctuator (#\,) punctuator-comma (lex (tag punctuator ",")))
|
||||
(production :punctuator (#\-) punctuator-minus (lex (tag punctuator "-")))
|
||||
(production :punctuator (#\- #\-) punctuator-decrement (lex (tag punctuator "--")))
|
||||
(production :punctuator (#\- #\=) punctuator-minus-equals (lex (tag punctuator "-=")))
|
||||
(production :punctuator (#\- #\>) punctuator-arrow (lex (tag punctuator "->")))
|
||||
(production :punctuator (#\.) punctuator-dot (lex (tag punctuator ".")))
|
||||
(production :punctuator (#\. #\.) punctuator-double-dot (lex (tag punctuator "..")))
|
||||
(production :punctuator (#\. #\. #\.) punctuator-triple-dot (lex (tag punctuator "...")))
|
||||
(production :punctuator (#\:) punctuator-colon (lex (tag punctuator ":")))
|
||||
(production :punctuator (#\: #\:) punctuator-namespace (lex (tag punctuator "::")))
|
||||
(production :punctuator (#\;) punctuator-semicolon (lex (tag punctuator ";")))
|
||||
(production :punctuator (#\<) punctuator-less-than (lex (tag punctuator "<")))
|
||||
(production :punctuator (#\< #\<) punctuator-left-shift (lex (tag punctuator "<<")))
|
||||
(production :punctuator (#\< #\< #\=) punctuator-left-shift-equals (lex (tag punctuator "<<=")))
|
||||
(production :punctuator (#\< #\=) punctuator-less-than-or-equal (lex (tag punctuator "<=")))
|
||||
(production :punctuator (#\=) punctuator-assignment (lex (tag punctuator "=")))
|
||||
(production :punctuator (#\= #\=) punctuator-equal (lex (tag punctuator "==")))
|
||||
(production :punctuator (#\= #\= #\=) punctuator-identical (lex (tag punctuator "===")))
|
||||
(production :punctuator (#\>) punctuator-greater-than (lex (tag punctuator ">")))
|
||||
(production :punctuator (#\> #\=) punctuator-greater-than-or-equal (lex (tag punctuator ">=")))
|
||||
(production :punctuator (#\> #\>) punctuator-right-shift (lex (tag punctuator ">>")))
|
||||
(production :punctuator (#\> #\> #\=) punctuator-right-shift-equals (lex (tag punctuator ">>=")))
|
||||
(production :punctuator (#\> #\> #\>) punctuator-logical-right-shift (lex (tag punctuator ">>>")))
|
||||
(production :punctuator (#\> #\> #\> #\=) punctuator-logical-right-shift-equals (lex (tag punctuator ">>>=")))
|
||||
(production :punctuator (#\?) punctuator-question (lex (tag punctuator "?")))
|
||||
(production :punctuator (#\@) punctuator-at (lex (tag punctuator "@")))
|
||||
(production :punctuator (#\[) punctuator-open-bracket (lex (tag punctuator "[")))
|
||||
(production :punctuator (#\]) punctuator-close-bracket (lex (tag punctuator "]")))
|
||||
(production :punctuator (#\^) punctuator-xor (lex (tag punctuator "^")))
|
||||
(production :punctuator (#\^ #\=) punctuator-xor-equals (lex (tag punctuator "^=")))
|
||||
(production :punctuator (#\^ #\^) punctuator-logical-xor (lex (tag punctuator "^^")))
|
||||
(production :punctuator (#\^ #\^ #\=) punctuator-logical-xor-equals (lex (tag punctuator "^^=")))
|
||||
(production :punctuator (#\{) punctuator-open-brace (lex (tag punctuator "{")))
|
||||
(production :punctuator (#\|) punctuator-or (lex (tag punctuator "|")))
|
||||
(production :punctuator (#\| #\=) punctuator-or-equals (lex (tag punctuator "|=")))
|
||||
(production :punctuator (#\| #\|) punctuator-logical-or (lex (tag punctuator "||")))
|
||||
(production :punctuator (#\| #\| #\=) punctuator-logical-or-equals (lex (tag punctuator "||=")))
|
||||
(production :punctuator (#\}) punctuator-close-brace (lex (tag punctuator "}")))
|
||||
(production :punctuator (#\~) punctuator-complement (lex (tag punctuator "~"))))
|
||||
|
||||
(rule :division-punctuator ((punctuator string))
|
||||
(production :division-punctuator (#\/ (:- #\/ #\*)) punctuator-divide (punctuator "/"))
|
||||
(production :division-punctuator (#\/ #\=) punctuator-divide-equals (punctuator "/=")))
|
||||
(rule :division-punctuator ((lex token))
|
||||
(production :division-punctuator (#\/ (:- #\/ #\*)) punctuator-divide (lex (tag punctuator "/")))
|
||||
(production :division-punctuator (#\/ #\=) punctuator-divide-equals (lex (tag punctuator "/="))))
|
||||
(%print-actions)
|
||||
|
||||
(%section "Numeric literals")
|
||||
|
||||
(rule :numeric-literal ((float64-value float64))
|
||||
(rule :numeric-literal ((lex token))
|
||||
(production :numeric-literal (:decimal-literal) numeric-literal-decimal
|
||||
(float64-value (rational-to-float64 (rational-value :decimal-literal))))
|
||||
(lex (tag number (real-to-float64 (lex-number :decimal-literal)))))
|
||||
(production :numeric-literal (:hex-integer-literal (:- :hex-digit)) numeric-literal-hex
|
||||
(float64-value (rational-to-float64 (integer-value :hex-integer-literal)))))
|
||||
(lex (tag number (real-to-float64 (lex-number :hex-integer-literal))))))
|
||||
(%print-actions)
|
||||
|
||||
(define (expt (base rational) (exponent integer)) rational
|
||||
(if (= exponent 0)
|
||||
1
|
||||
(if (< exponent 0)
|
||||
(rational/ 1 (expt base (neg exponent)))
|
||||
(rational* base (expt base (- exponent 1))))))
|
||||
|
||||
(rule :decimal-literal ((rational-value rational))
|
||||
(rule :decimal-literal ((lex-number rational))
|
||||
(production :decimal-literal (:mantissa) decimal-literal
|
||||
(rational-value (rational-value :mantissa)))
|
||||
(lex-number (lex-number :mantissa)))
|
||||
(production :decimal-literal (:mantissa :letter-e :signed-integer) decimal-literal-exponent
|
||||
(rational-value (rational* (rational-value :mantissa) (expt 10 (integer-value :signed-integer))))))
|
||||
(lex-number (rat* (lex-number :mantissa) (expt 10 (lex-number :signed-integer))))))
|
||||
|
||||
(%charclass :letter-e)
|
||||
|
||||
(rule :mantissa ((rational-value rational))
|
||||
(rule :mantissa ((lex-number rational))
|
||||
(production :mantissa (:decimal-integer-literal) mantissa-integer
|
||||
(rational-value (integer-value :decimal-integer-literal)))
|
||||
(lex-number (lex-number :decimal-integer-literal)))
|
||||
(production :mantissa (:decimal-integer-literal #\.) mantissa-integer-dot
|
||||
(rational-value (integer-value :decimal-integer-literal)))
|
||||
(lex-number (lex-number :decimal-integer-literal)))
|
||||
(production :mantissa (:decimal-integer-literal #\. :fraction) mantissa-integer-dot-fraction
|
||||
(rational-value (rational+ (integer-value :decimal-integer-literal)
|
||||
(rational-value :fraction))))
|
||||
(lex-number (rat+ (lex-number :decimal-integer-literal)
|
||||
(lex-number :fraction))))
|
||||
(production :mantissa (#\. :fraction) mantissa-dot-fraction
|
||||
(rational-value (rational-value :fraction))))
|
||||
(lex-number (lex-number :fraction))))
|
||||
|
||||
(rule :decimal-integer-literal ((integer-value integer))
|
||||
(rule :decimal-integer-literal ((lex-number integer))
|
||||
(production :decimal-integer-literal (#\0) decimal-integer-literal-0
|
||||
(integer-value 0))
|
||||
(lex-number 0))
|
||||
(production :decimal-integer-literal (:non-zero-decimal-digits) decimal-integer-literal-nonzero
|
||||
(integer-value (integer-value :non-zero-decimal-digits))))
|
||||
(lex-number (lex-number :non-zero-decimal-digits))))
|
||||
|
||||
(rule :non-zero-decimal-digits ((integer-value integer))
|
||||
(rule :non-zero-decimal-digits ((lex-number integer))
|
||||
(production :non-zero-decimal-digits (:non-zero-digit) non-zero-decimal-digits-first
|
||||
(integer-value (decimal-value :non-zero-digit)))
|
||||
(lex-number (decimal-value :non-zero-digit)))
|
||||
(production :non-zero-decimal-digits (:non-zero-decimal-digits :a-s-c-i-i-digit) non-zero-decimal-digits-rest
|
||||
(integer-value (+ (* 10 (integer-value :non-zero-decimal-digits)) (decimal-value :a-s-c-i-i-digit)))))
|
||||
(lex-number (+ (* 10 (lex-number :non-zero-decimal-digits)) (decimal-value :a-s-c-i-i-digit)))))
|
||||
|
||||
(%charclass :non-zero-digit)
|
||||
|
||||
(rule :fraction ((rational-value rational))
|
||||
(rule :fraction ((lex-number rational))
|
||||
(production :fraction (:decimal-digits) fraction-decimal-digits
|
||||
(rational-value (rational/ (integer-value :decimal-digits)
|
||||
(expt 10 (n-digits :decimal-digits))))))
|
||||
(lex-number (rat/ (lex-number :decimal-digits)
|
||||
(expt 10 (n-digits :decimal-digits))))))
|
||||
(%print-actions)
|
||||
|
||||
(rule :signed-integer ((integer-value integer))
|
||||
(rule :signed-integer ((lex-number integer))
|
||||
(production :signed-integer (:decimal-digits) signed-integer-no-sign
|
||||
(integer-value (integer-value :decimal-digits)))
|
||||
(lex-number (lex-number :decimal-digits)))
|
||||
(production :signed-integer (#\+ :decimal-digits) signed-integer-plus
|
||||
(integer-value (integer-value :decimal-digits)))
|
||||
(lex-number (lex-number :decimal-digits)))
|
||||
(production :signed-integer (#\- :decimal-digits) signed-integer-minus
|
||||
(integer-value (neg (integer-value :decimal-digits)))))
|
||||
(lex-number (neg (lex-number :decimal-digits)))))
|
||||
(%print-actions)
|
||||
|
||||
(rule :decimal-digits
|
||||
((integer-value integer) (n-digits integer))
|
||||
((lex-number integer) (n-digits integer))
|
||||
(production :decimal-digits (:a-s-c-i-i-digit) decimal-digits-first
|
||||
(integer-value (decimal-value :a-s-c-i-i-digit))
|
||||
(lex-number (decimal-value :a-s-c-i-i-digit))
|
||||
(n-digits 1))
|
||||
(production :decimal-digits (:decimal-digits :a-s-c-i-i-digit) decimal-digits-rest
|
||||
(integer-value (+ (* 10 (integer-value :decimal-digits)) (decimal-value :a-s-c-i-i-digit)))
|
||||
(lex-number (+ (* 10 (lex-number :decimal-digits)) (decimal-value :a-s-c-i-i-digit)))
|
||||
(n-digits (+ (n-digits :decimal-digits) 1))))
|
||||
(%print-actions)
|
||||
|
||||
(rule :hex-integer-literal ((integer-value integer))
|
||||
(rule :hex-integer-literal ((lex-number integer))
|
||||
(production :hex-integer-literal (#\0 :letter-x :hex-digit) hex-integer-literal-first
|
||||
(integer-value (hex-value :hex-digit)))
|
||||
(lex-number (hex-value :hex-digit)))
|
||||
(production :hex-integer-literal (:hex-integer-literal :hex-digit) hex-integer-literal-rest
|
||||
(integer-value (+ (* 16 (integer-value :hex-integer-literal)) (hex-value :hex-digit)))))
|
||||
(lex-number (+ (* 16 (lex-number :hex-integer-literal)) (hex-value :hex-digit)))))
|
||||
(%charclass :letter-x)
|
||||
(%charclass :hex-digit)
|
||||
(%print-actions)
|
||||
|
|
@ -412,100 +406,100 @@
|
|||
(%section "String literals")
|
||||
|
||||
(grammar-argument :theta single double)
|
||||
(rule :string-literal ((string-value string))
|
||||
(rule :string-literal ((lex token))
|
||||
(production :string-literal (#\' (:string-chars single) #\') string-literal-single
|
||||
(string-value (string-value :string-chars)))
|
||||
(lex (tag string (lex-string :string-chars))))
|
||||
(production :string-literal (#\" (:string-chars double) #\") string-literal-double
|
||||
(string-value (string-value :string-chars))))
|
||||
(lex (tag string (lex-string :string-chars)))))
|
||||
(%print-actions)
|
||||
|
||||
(rule (:string-chars :theta) ((string-value string))
|
||||
(rule (:string-chars :theta) ((lex-string string))
|
||||
(production (:string-chars :theta) () string-chars-none
|
||||
(string-value ""))
|
||||
(lex-string ""))
|
||||
(production (:string-chars :theta) ((:string-chars :theta) (:string-char :theta)) string-chars-some
|
||||
(string-value (append (string-value :string-chars)
|
||||
(vector (character-value :string-char)))))
|
||||
(lex-string (append (lex-string :string-chars)
|
||||
(vector (lex-char :string-char)))))
|
||||
(production (:string-chars :theta) ((:string-chars :theta) :null-escape) string-chars-null-escape
|
||||
(string-value (string-value :string-chars))))
|
||||
(lex-string (lex-string :string-chars))))
|
||||
|
||||
(rule (:string-char :theta) ((character-value character))
|
||||
(rule (:string-char :theta) ((lex-char character))
|
||||
(production (:string-char :theta) ((:literal-string-char :theta)) string-char-literal
|
||||
(character-value ($default-action :literal-string-char)))
|
||||
(lex-char ($default-action :literal-string-char)))
|
||||
(production (:string-char :theta) (#\\ :string-escape) string-char-escape
|
||||
(character-value (character-value :string-escape))))
|
||||
(lex-char (lex-char :string-escape))))
|
||||
|
||||
(%charclass (:literal-string-char single))
|
||||
(%charclass (:literal-string-char double))
|
||||
(%print-actions)
|
||||
|
||||
(rule :string-escape ((character-value character))
|
||||
(rule :string-escape ((lex-char character))
|
||||
(production :string-escape (:control-escape) string-escape-control
|
||||
(character-value (character-value :control-escape)))
|
||||
(lex-char (lex-char :control-escape)))
|
||||
(production :string-escape (:zero-escape) string-escape-zero
|
||||
(character-value (character-value :zero-escape)))
|
||||
(lex-char (lex-char :zero-escape)))
|
||||
(production :string-escape (:hex-escape) string-escape-hex
|
||||
(character-value (character-value :hex-escape)))
|
||||
(lex-char (lex-char :hex-escape)))
|
||||
(production :string-escape (:identity-escape) string-escape-non-escape
|
||||
(character-value ($default-action :identity-escape))))
|
||||
(lex-char ($default-action :identity-escape))))
|
||||
(%charclass :identity-escape)
|
||||
(%print-actions)
|
||||
|
||||
(rule :control-escape ((character-value character))
|
||||
(production :control-escape (#\b) control-escape-backspace (character-value #?0008))
|
||||
(production :control-escape (#\f) control-escape-form-feed (character-value #?000C))
|
||||
(production :control-escape (#\n) control-escape-new-line (character-value #?000A))
|
||||
(production :control-escape (#\r) control-escape-return (character-value #?000D))
|
||||
(production :control-escape (#\t) control-escape-tab (character-value #?0009))
|
||||
(production :control-escape (#\v) control-escape-vertical-tab (character-value #?000B)))
|
||||
(rule :control-escape ((lex-char character))
|
||||
(production :control-escape (#\b) control-escape-backspace (lex-char #?0008))
|
||||
(production :control-escape (#\f) control-escape-form-feed (lex-char #?000C))
|
||||
(production :control-escape (#\n) control-escape-new-line (lex-char #?000A))
|
||||
(production :control-escape (#\r) control-escape-return (lex-char #?000D))
|
||||
(production :control-escape (#\t) control-escape-tab (lex-char #?0009))
|
||||
(production :control-escape (#\v) control-escape-vertical-tab (lex-char #?000B)))
|
||||
(%print-actions)
|
||||
|
||||
(rule :zero-escape ((character-value character))
|
||||
(rule :zero-escape ((lex-char character))
|
||||
(production :zero-escape (#\0 (:- :a-s-c-i-i-digit)) zero-escape-zero
|
||||
(character-value #?0000)))
|
||||
(lex-char #?0000)))
|
||||
(%print-actions)
|
||||
|
||||
(rule :hex-escape ((character-value character))
|
||||
(rule :hex-escape ((lex-char character))
|
||||
(production :hex-escape (#\x :hex-digit :hex-digit) hex-escape-2
|
||||
(character-value (code-to-character (+ (* 16 (hex-value :hex-digit 1))
|
||||
(hex-value :hex-digit 2)))))
|
||||
(lex-char (code-to-character (+ (* 16 (hex-value :hex-digit 1))
|
||||
(hex-value :hex-digit 2)))))
|
||||
(production :hex-escape (#\u :hex-digit :hex-digit :hex-digit :hex-digit) hex-escape-4
|
||||
(character-value (code-to-character (+ (+ (+ (* 4096 (hex-value :hex-digit 1))
|
||||
(* 256 (hex-value :hex-digit 2)))
|
||||
(* 16 (hex-value :hex-digit 3)))
|
||||
(hex-value :hex-digit 4))))))
|
||||
(lex-char (code-to-character (+ (+ (+ (* 4096 (hex-value :hex-digit 1))
|
||||
(* 256 (hex-value :hex-digit 2)))
|
||||
(* 16 (hex-value :hex-digit 3)))
|
||||
(hex-value :hex-digit 4))))))
|
||||
|
||||
(%print-actions)
|
||||
|
||||
(%section "Regular expression literals")
|
||||
|
||||
(rule :reg-exp-literal ((r-e-value reg-exp))
|
||||
(rule :reg-exp-literal ((lex token))
|
||||
(production :reg-exp-literal (:reg-exp-body :reg-exp-flags) reg-exp-literal
|
||||
(r-e-value (tuple reg-exp (r-e-body :reg-exp-body) (r-e-flags :reg-exp-flags)))))
|
||||
(lex (tag regular-expression (lex-string :reg-exp-body) (lex-string :reg-exp-flags)))))
|
||||
|
||||
(rule :reg-exp-flags ((r-e-flags string))
|
||||
(rule :reg-exp-flags ((lex-string string))
|
||||
(production :reg-exp-flags () reg-exp-flags-none
|
||||
(r-e-flags ""))
|
||||
(lex-string ""))
|
||||
(production :reg-exp-flags (:reg-exp-flags :continuing-identifier-character-or-escape) reg-exp-flags-more
|
||||
(r-e-flags (append (r-e-flags :reg-exp-flags) (vector (character-value :continuing-identifier-character-or-escape)))))
|
||||
(lex-string (append (lex-string :reg-exp-flags) (vector (lex-char :continuing-identifier-character-or-escape)))))
|
||||
(production :reg-exp-flags (:reg-exp-flags :null-escape) reg-exp-flags-null-escape
|
||||
(r-e-flags (r-e-flags :reg-exp-flags))))
|
||||
(lex-string (lex-string :reg-exp-flags))))
|
||||
|
||||
(rule :reg-exp-body ((r-e-body string))
|
||||
(rule :reg-exp-body ((lex-string string))
|
||||
(production :reg-exp-body (#\/ (:- #\*) :reg-exp-chars #\/) reg-exp-body
|
||||
(r-e-body (r-e-body :reg-exp-chars))))
|
||||
(lex-string (lex-string :reg-exp-chars))))
|
||||
|
||||
(rule :reg-exp-chars ((r-e-body string))
|
||||
(rule :reg-exp-chars ((lex-string string))
|
||||
(production :reg-exp-chars (:reg-exp-char) reg-exp-chars-one
|
||||
(r-e-body (r-e-body :reg-exp-char)))
|
||||
(lex-string (lex-string :reg-exp-char)))
|
||||
(production :reg-exp-chars (:reg-exp-chars :reg-exp-char) reg-exp-chars-more
|
||||
(r-e-body (append (r-e-body :reg-exp-chars)
|
||||
(r-e-body :reg-exp-char)))))
|
||||
(lex-string (append (lex-string :reg-exp-chars)
|
||||
(lex-string :reg-exp-char)))))
|
||||
|
||||
(rule :reg-exp-char ((r-e-body string))
|
||||
(rule :reg-exp-char ((lex-string string))
|
||||
(production :reg-exp-char (:ordinary-reg-exp-char) reg-exp-char-ordinary
|
||||
(r-e-body (vector ($default-action :ordinary-reg-exp-char))))
|
||||
(lex-string (vector ($default-action :ordinary-reg-exp-char))))
|
||||
(production :reg-exp-char (#\\ :non-terminator) reg-exp-char-escape
|
||||
(r-e-body (vector #\\ ($default-action :non-terminator)))))
|
||||
(lex-string (vector #\\ ($default-action :non-terminator)))))
|
||||
|
||||
(%charclass :ordinary-reg-exp-char)
|
||||
)))
|
||||
|
|
@ -521,41 +515,39 @@
|
|||
"JS20/LexerCharClasses.rtf"
|
||||
"JavaScript 2 Lexical Character Classes"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-paragraph (rtf-stream ':grammar-header)
|
||||
(depict-paragraph (rtf-stream :grammar-header)
|
||||
(depict rtf-stream "Character Classes"))
|
||||
(dolist (charclass (lexer-charclasses *ll*))
|
||||
(depict-charclass rtf-stream charclass))
|
||||
(depict-paragraph (rtf-stream ':grammar-header)
|
||||
(depict-paragraph (rtf-stream :grammar-header)
|
||||
(depict rtf-stream "Grammar"))
|
||||
(depict-grammar rtf-stream *lg*)))
|
||||
|
||||
(values
|
||||
(depict-rtf-to-local-file
|
||||
"JS20/LexerGrammar.rtf"
|
||||
"JavaScript 2 Lexical Grammar"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *lw* :visible-semantics nil)))
|
||||
(depict-rtf-to-local-file
|
||||
"JS20/LexerSemantics.rtf"
|
||||
"JavaScript 2 Lexical Semantics"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *lw*))))
|
||||
|
||||
(values
|
||||
(depict-html-to-local-file
|
||||
"JS20/LexerGrammar.html"
|
||||
"JavaScript 2 Lexical Grammar"
|
||||
t
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *lw* :visible-semantics nil))
|
||||
:external-link-base "notation.html")
|
||||
(depict-html-to-local-file
|
||||
"JS20/LexerSemantics.html"
|
||||
"JavaScript 2 Lexical Semantics"
|
||||
t
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *lw*))
|
||||
:external-link-base "notation.html"))
|
||||
(depict-rtf-to-local-file
|
||||
"JS20/LexerGrammar.rtf"
|
||||
"JavaScript 2 Lexical Grammar"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *lw* :visible-semantics nil)))
|
||||
(depict-rtf-to-local-file
|
||||
"JS20/LexerSemantics.rtf"
|
||||
"JavaScript 2 Lexical Semantics"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *lw*)))
|
||||
(depict-html-to-local-file
|
||||
"JS20/LexerGrammar.html"
|
||||
"JavaScript 2 Lexical Grammar"
|
||||
t
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *lw* :visible-semantics nil))
|
||||
:external-link-base "notation.html")
|
||||
(depict-html-to-local-file
|
||||
"JS20/LexerSemantics.html"
|
||||
"JavaScript 2 Lexical Semantics"
|
||||
t
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *lw*))
|
||||
:external-link-base "notation.html"))
|
||||
|
||||
(with-local-output (s "JS20/LexerGrammar.txt") (print-lexer *ll* s) (print-grammar *lg* s))
|
||||
|
||||
|
|
|
|||
Разница между файлами не показана из-за своего большого размера
Загрузить разницу
|
|
@ -41,7 +41,8 @@
|
|||
(($default-action character nil identity)
|
||||
($digit-value integer digit-value digit-char-36)))
|
||||
|
||||
(deftype semantic-exception (oneof syntax-error))
|
||||
(deftag syntax-error)
|
||||
(deftype semantic-exception (tag syntax-error))
|
||||
|
||||
(%section "Unicode Character Classes")
|
||||
(%charclass :unicode-character)
|
||||
|
|
@ -56,34 +57,38 @@
|
|||
|
||||
|
||||
(%section "Regular Expression Definitions")
|
||||
(deftype r-e-input (tuple (str string) (ignore-case boolean) (multiline boolean) (span boolean)))
|
||||
(deftag re-input (str string) (ignore-case boolean) (multiline boolean) (span boolean))
|
||||
(deftype r-e-input (tag re-input))
|
||||
(%text :semantics
|
||||
"Field " (:field str r-e-input) " is the input string. "
|
||||
(:field ignore-case r-e-input) ", "
|
||||
(:field multiline r-e-input) ", and "
|
||||
(:field span r-e-input) " are the corresponding regular expression flags.")
|
||||
"Field " (:label re-input str) " is the input string. "
|
||||
(:label re-input ignore-case) ", "
|
||||
(:label re-input multiline) ", and "
|
||||
(:label re-input span) " are the corresponding regular expression flags.")
|
||||
|
||||
(deftype r-e-result (oneof (success r-e-match) failure))
|
||||
(deftype r-e-match (tuple (end-index integer)
|
||||
(captures (vector capture))))
|
||||
(deftag present (s string))
|
||||
(deftag absent)
|
||||
(deftype capture (tag present absent))
|
||||
|
||||
(deftag re-match (end-index integer) (captures (vector capture)))
|
||||
(deftype r-e-match (tag re-match))
|
||||
(deftag failure)
|
||||
(deftype r-e-result (tag re-match failure))
|
||||
(%text :semantics
|
||||
"A " (:type r-e-match) " holds an intermediate state during the pattern-matching process. "
|
||||
(:field end-index r-e-match)
|
||||
(:label re-match end-index)
|
||||
" is the index of the next input character to be matched by the next component in a regular expression pattern. "
|
||||
"If we are at the end of the pattern, " (:field end-index r-e-match)
|
||||
"If we are at the end of the pattern, " (:label re-match end-index)
|
||||
" is one plus the index of the last matched input character. "
|
||||
(:field captures r-e-match)
|
||||
(:label re-match captures)
|
||||
" is a zero-based array of the strings captured so far by capturing parentheses.")
|
||||
|
||||
(deftype capture (oneof (present string)
|
||||
absent))
|
||||
(deftype continuation (-> (r-e-match) r-e-result))
|
||||
(%text :semantics
|
||||
"A " (:type continuation)
|
||||
" is a function that attempts to match the remaining portion of the pattern against the input string, "
|
||||
"starting at the intermediate state given by its " (:type r-e-match) " argument. "
|
||||
"If a match is possible, it returns a " (:field success r-e-result) " result that contains the final "
|
||||
(:type r-e-match) " state; if no match is possible, it returns a " (:field failure r-e-result) " result.")
|
||||
"If a match is possible, it returns a " (:tag re-match)
|
||||
" result that contains the final state; if no match is possible, it returns a " (:tag failure) " result.")
|
||||
|
||||
(deftype matcher (-> (r-e-input r-e-match continuation) r-e-result))
|
||||
(%text :semantics
|
||||
|
|
@ -92,37 +97,37 @@
|
|||
"starting at the intermediate state given by its " (:type r-e-match) " argument. "
|
||||
"Since the remainder of the pattern heavily influences whether (and how) a middle portion will match, we "
|
||||
"must pass in a " (:type continuation) " function that checks whether the rest of the pattern matched. "
|
||||
"If the continuation returns " (:field failure r-e-result) ", the matcher function may call it repeatedly, "
|
||||
"If the continuation returns " (:tag failure) ", the matcher function may call it repeatedly, "
|
||||
"trying various alternatives at pattern choice points.")
|
||||
(%text :semantics
|
||||
"The " (:type r-e-input) " parameter contains the input string and is merely passed down to subroutines.")
|
||||
|
||||
(deftype matcher-generator (-> (integer) matcher))
|
||||
(%text :semantics
|
||||
"A " (:type matcher-generator)
|
||||
"A " (:type (-> (integer) matcher))
|
||||
" is a function executed at the time the regular expression is compiled that returns a " (:type matcher) " for a part "
|
||||
"of the pattern. The " (:type integer) " parameter contains the number of capturing left parentheses seen so far in the "
|
||||
"pattern and is used to assign static, consecutive numbers to capturing parentheses.")
|
||||
|
||||
(define (character-set-matcher (acceptance-set (set character)) (invert boolean)) matcher ;*********ignore case?
|
||||
(function ((t r-e-input) (x r-e-match) (c continuation))
|
||||
(let ((i integer (& end-index x))
|
||||
(s string (& str t)))
|
||||
(if (= i (length s))
|
||||
(oneof failure)
|
||||
(if (xor (character-set-member (nth s i) acceptance-set) invert)
|
||||
(c (tuple r-e-match (+ i 1) (& captures x)))
|
||||
(oneof failure))))))
|
||||
(function (m (t r-e-input) (x r-e-match) (c continuation)) r-e-result
|
||||
(const i integer (& end-index x))
|
||||
(const s string (& str t))
|
||||
(cond
|
||||
((= i (length s)) (return failure))
|
||||
((xor (character-set-member (nth s i) acceptance-set) invert)
|
||||
(return (c (tag re-match (+ i 1) (& captures x)))))
|
||||
(nil (return failure))))
|
||||
(return m))
|
||||
(%text :semantics
|
||||
(:global character-set-matcher) " returns a " (:type matcher)
|
||||
" that matches a single input string character. If "
|
||||
(:local invert) " is false, the match succeeds if the character is a member of the "
|
||||
(:local invert) " is " (:tag false) ", the match succeeds if the character is a member of the "
|
||||
(:local acceptance-set) " set of characters (possibly ignoring case). If "
|
||||
(:local invert) " is true, the match succeeds if the character is not a member of the "
|
||||
(:local invert) " is " (:tag true) ", the match succeeds if the character is not a member of the "
|
||||
(:local acceptance-set) " set of characters (possibly ignoring case).")
|
||||
|
||||
(define (character-matcher (ch character)) matcher
|
||||
(character-set-matcher (set-of character ch) false))
|
||||
(return (character-set-matcher (set-of character ch) false)))
|
||||
(%text :semantics
|
||||
(:global character-matcher) " returns a " (:type matcher)
|
||||
" that matches a single input string character. The match succeeds if the character is the same as "
|
||||
|
|
@ -133,39 +138,41 @@
|
|||
|
||||
(%section "Regular Expression Patterns")
|
||||
|
||||
(rule :regular-expression-pattern ((exec (-> (r-e-input integer) r-e-result)))
|
||||
(rule :regular-expression-pattern ((execute (-> (r-e-input integer) r-e-result)))
|
||||
(production :regular-expression-pattern (:disjunction) regular-expression-pattern-disjunction
|
||||
(exec
|
||||
(let ((match matcher ((gen-matcher :disjunction) 0)))
|
||||
(function ((t r-e-input) (index integer))
|
||||
(match
|
||||
t
|
||||
(tuple r-e-match index (fill-capture (count-parens :disjunction)))
|
||||
success-continuation))))))
|
||||
(execute
|
||||
(begin
|
||||
(const m1 matcher ((gen-matcher :disjunction) 0))
|
||||
(function (e (t r-e-input) (index integer)) r-e-result
|
||||
(const x r-e-match (tag re-match index (fill-capture (count-parens :disjunction))))
|
||||
(return (m1 t x success-continuation)))
|
||||
(return e)))))
|
||||
|
||||
(%print-actions)
|
||||
(define (success-continuation (x r-e-match)) r-e-result
|
||||
(oneof success x))
|
||||
(return x))
|
||||
(define (fill-capture (i integer)) (vector capture)
|
||||
(if (= i 0)
|
||||
(vector-of capture)
|
||||
(append (fill-capture (- i 1)) (vector (oneof absent)))))
|
||||
(return (vector-of capture))
|
||||
(return (append (fill-capture (- i 1)) (vector-of capture absent)))))
|
||||
|
||||
|
||||
(%subsection "Disjunctions")
|
||||
|
||||
(rule :disjunction ((gen-matcher matcher-generator) (count-parens integer))
|
||||
(rule :disjunction ((gen-matcher (-> (integer) matcher)) (count-parens integer))
|
||||
(production :disjunction (:alternative) disjunction-one
|
||||
(gen-matcher (gen-matcher :alternative))
|
||||
(count-parens (count-parens :alternative)))
|
||||
(production :disjunction (:alternative #\| :disjunction) disjunction-more
|
||||
((gen-matcher (paren-index integer))
|
||||
(let ((match1 matcher ((gen-matcher :alternative) paren-index))
|
||||
(match2 matcher ((gen-matcher :disjunction) (+ paren-index (count-parens :alternative)))))
|
||||
(function ((t r-e-input) (x r-e-match) (c continuation))
|
||||
(case (match1 t x c)
|
||||
((success y r-e-match) (oneof success y))
|
||||
(failure (match2 t x c))))))
|
||||
((gen-matcher paren-index)
|
||||
(const m1 matcher ((gen-matcher :alternative) paren-index))
|
||||
(const m2 matcher ((gen-matcher :disjunction) (+ paren-index (count-parens :alternative))))
|
||||
(function (m3 (t r-e-input) (x r-e-match) (c continuation)) r-e-result
|
||||
(const y r-e-result (m1 t x c))
|
||||
(case y
|
||||
(:select r-e-match (return y))
|
||||
(:select (tag failure) (return (m2 t x c)))))
|
||||
(return m3))
|
||||
(count-parens (+ (count-parens :alternative) (count-parens :disjunction)))))
|
||||
|
||||
(%print-actions)
|
||||
|
|
@ -173,20 +180,22 @@
|
|||
|
||||
(%subsection "Alternatives")
|
||||
|
||||
(rule :alternative ((gen-matcher matcher-generator) (count-parens integer))
|
||||
(rule :alternative ((gen-matcher (-> (integer) matcher)) (count-parens integer))
|
||||
(production :alternative () alternative-none
|
||||
((gen-matcher (paren-index integer :unused))
|
||||
(function ((t r-e-input :unused) (x r-e-match) (c continuation))
|
||||
(c x)))
|
||||
((gen-matcher (paren-index :unused))
|
||||
(function (m (t r-e-input :unused) (x r-e-match) (c continuation)) r-e-result
|
||||
(return (c x)))
|
||||
(return m))
|
||||
(count-parens 0))
|
||||
(production :alternative (:alternative :term) alternative-some
|
||||
((gen-matcher (paren-index integer))
|
||||
(let ((match1 matcher ((gen-matcher :alternative) paren-index))
|
||||
(match2 matcher ((gen-matcher :term) (+ paren-index (count-parens :alternative)))))
|
||||
(function ((t r-e-input) (x r-e-match) (c continuation))
|
||||
(let ((d continuation (function ((y r-e-match))
|
||||
(match2 t y c))))
|
||||
(match1 t x d)))))
|
||||
((gen-matcher paren-index)
|
||||
(const m1 matcher ((gen-matcher :alternative) paren-index))
|
||||
(const m2 matcher ((gen-matcher :term) (+ paren-index (count-parens :alternative))))
|
||||
(function (m3 (t r-e-input) (x r-e-match) (c continuation)) r-e-result
|
||||
(function (d (y r-e-match)) r-e-result
|
||||
(return (m2 t y c)))
|
||||
(return (m1 t x d)))
|
||||
(return m3))
|
||||
(count-parens (+ (count-parens :alternative) (count-parens :term)))))
|
||||
|
||||
(%print-actions)
|
||||
|
|
@ -194,28 +203,28 @@
|
|||
|
||||
(%subsection "Terms")
|
||||
|
||||
(rule :term ((gen-matcher matcher-generator) (count-parens integer))
|
||||
(rule :term ((gen-matcher (-> (integer) matcher)) (count-parens integer))
|
||||
(production :term (:assertion) term-assertion
|
||||
((gen-matcher (paren-index integer :unused))
|
||||
(function ((t r-e-input) (x r-e-match) (c continuation))
|
||||
((gen-matcher (paren-index :unused))
|
||||
(function (m (t r-e-input) (x r-e-match) (c continuation)) r-e-result
|
||||
(if ((test-assertion :assertion) t x)
|
||||
(c x)
|
||||
(oneof failure))))
|
||||
(return (c x))
|
||||
(return failure)))
|
||||
(return m))
|
||||
(count-parens 0))
|
||||
(production :term (:atom) term-atom
|
||||
(gen-matcher (gen-matcher :atom))
|
||||
(count-parens (count-parens :atom)))
|
||||
(production :term (:atom :quantifier) term-quantified-atom
|
||||
((gen-matcher (paren-index integer))
|
||||
(let ((match matcher ((gen-matcher :atom) paren-index))
|
||||
(min integer (minimum :quantifier))
|
||||
(max limit (maximum :quantifier))
|
||||
(greedy boolean (greedy :quantifier)))
|
||||
(if (case max
|
||||
((finite m integer) (< m min))
|
||||
(infinite false))
|
||||
(throw (oneof syntax-error))
|
||||
(repeat-matcher match min max greedy paren-index (count-parens :atom)))))
|
||||
((gen-matcher paren-index)
|
||||
(const m matcher ((gen-matcher :atom) paren-index))
|
||||
(const min integer (minimum :quantifier))
|
||||
(const max limit (maximum :quantifier))
|
||||
(const greedy boolean (greedy :quantifier))
|
||||
(when (:narrow-true (not-in (tag +infinity) max))
|
||||
(rwhen (< max min)
|
||||
(throw syntax-error)))
|
||||
(return (repeat-matcher m min max greedy paren-index (count-parens :atom))))
|
||||
(count-parens (count-parens :atom))))
|
||||
|
||||
(%print-actions)
|
||||
|
|
@ -234,22 +243,22 @@
|
|||
(rule :quantifier-prefix ((minimum integer) (maximum limit))
|
||||
(production :quantifier-prefix (#\*) quantifier-prefix-zero-or-more
|
||||
(minimum 0)
|
||||
(maximum (oneof infinite)))
|
||||
(maximum +infinity))
|
||||
(production :quantifier-prefix (#\+) quantifier-prefix-one-or-more
|
||||
(minimum 1)
|
||||
(maximum (oneof infinite)))
|
||||
(maximum +infinity))
|
||||
(production :quantifier-prefix (#\?) quantifier-prefix-zero-or-one
|
||||
(minimum 0)
|
||||
(maximum (oneof finite 1)))
|
||||
(maximum 1))
|
||||
(production :quantifier-prefix (#\{ :decimal-digits #\}) quantifier-prefix-repeat
|
||||
(minimum (integer-value :decimal-digits))
|
||||
(maximum (oneof finite (integer-value :decimal-digits))))
|
||||
(maximum (integer-value :decimal-digits)))
|
||||
(production :quantifier-prefix (#\{ :decimal-digits #\, #\}) quantifier-prefix-repeat-or-more
|
||||
(minimum (integer-value :decimal-digits))
|
||||
(maximum (oneof infinite)))
|
||||
(maximum +infinity))
|
||||
(production :quantifier-prefix (#\{ :decimal-digits #\, :decimal-digits #\}) quantifier-prefix-repeat-range
|
||||
(minimum (integer-value :decimal-digits 1))
|
||||
(maximum (oneof finite (integer-value :decimal-digits 2)))))
|
||||
(maximum (integer-value :decimal-digits 2))))
|
||||
|
||||
(rule :decimal-digits ((integer-value integer))
|
||||
(production :decimal-digits (:decimal-digit) decimal-digits-first
|
||||
|
|
@ -259,40 +268,45 @@
|
|||
(%charclass :decimal-digit)
|
||||
|
||||
|
||||
(deftype limit (oneof (finite integer) infinite))
|
||||
(deftype limit (union integer (tag +infinity)))
|
||||
|
||||
(define (reset-parens (x r-e-match) (p integer) (n-parens integer)) r-e-match
|
||||
(if (= n-parens 0)
|
||||
x
|
||||
(let ((y r-e-match (tuple r-e-match (& end-index x)
|
||||
(set-nth (& captures x) p (oneof absent)))))
|
||||
(reset-parens y (+ p 1) (- n-parens 1)))))
|
||||
(var captures (vector capture) (& captures x))
|
||||
(var i integer p)
|
||||
(while (< i (+ p n-parens))
|
||||
(<- captures (set-nth captures i absent))
|
||||
(<- i (+ i 1)))
|
||||
(return (tag re-match (& end-index x) captures)))
|
||||
|
||||
(define (repeat-matcher (body matcher) (min integer) (max limit) (greedy boolean) (paren-index integer) (n-body-parens integer)) matcher
|
||||
(function ((t r-e-input) (x r-e-match) (c continuation))
|
||||
(if (case max
|
||||
((finite m integer) (= m 0))
|
||||
(infinite false))
|
||||
(c x)
|
||||
(let ((d continuation (function ((y r-e-match))
|
||||
(if (and (= min 0)
|
||||
(= (& end-index y) (& end-index x)))
|
||||
(oneof failure)
|
||||
(let ((new-min integer (if (= min 0) 0 (- min 1)))
|
||||
(new-max limit (case max
|
||||
((finite m integer) (oneof finite (- m 1)))
|
||||
(infinite (oneof infinite)))))
|
||||
((repeat-matcher body new-min new-max greedy paren-index n-body-parens) t y c)))))
|
||||
(xr r-e-match (reset-parens x paren-index n-body-parens)))
|
||||
(if (/= min 0)
|
||||
(body t xr d)
|
||||
(if greedy
|
||||
(case (body t xr d)
|
||||
((success z r-e-match) (oneof success z))
|
||||
(failure (c x)))
|
||||
(case (c x)
|
||||
((success z r-e-match) (oneof success z))
|
||||
(failure (body t xr d)))))))))
|
||||
(function (m (t r-e-input) (x r-e-match) (c continuation)) r-e-result
|
||||
(rwhen (= max 0 limit)
|
||||
(return (c x)))
|
||||
(function (d (y r-e-match)) r-e-result
|
||||
(rwhen (and (= min 0) (= (& end-index y) (& end-index x)))
|
||||
(return failure))
|
||||
(var new-min integer min)
|
||||
(when (/= min 0)
|
||||
(<- new-min (- min 1)))
|
||||
(var new-max limit max)
|
||||
(when (:narrow-true (not-in (tag +infinity) max))
|
||||
(<- new-max (- max 1)))
|
||||
(const m2 matcher (repeat-matcher body new-min new-max greedy paren-index n-body-parens))
|
||||
(return (m2 t y c)))
|
||||
(const xr r-e-match (reset-parens x paren-index n-body-parens))
|
||||
(cond
|
||||
((/= min 0) (return (body t xr d)))
|
||||
(greedy
|
||||
(const z r-e-result (body t xr d))
|
||||
(case z
|
||||
(:select r-e-match (return z))
|
||||
(:select (tag failure) (return (c x)))))
|
||||
(nil
|
||||
(const z r-e-result (c x))
|
||||
(case z
|
||||
(:select r-e-match (return z))
|
||||
(:select (tag failure) (return (body t xr d)))))))
|
||||
(return m))
|
||||
|
||||
(%print-actions)
|
||||
|
||||
|
|
@ -301,95 +315,100 @@
|
|||
|
||||
(rule :assertion ((test-assertion (-> (r-e-input r-e-match) boolean)))
|
||||
(production :assertion (#\^) assertion-beginning
|
||||
((test-assertion (t r-e-input) (x r-e-match))
|
||||
(if (= (& end-index x) 0)
|
||||
true
|
||||
(and (& multiline t)
|
||||
(character-set-member (nth (& str t) (- (& end-index x) 1)) line-terminators)))))
|
||||
((test-assertion t x)
|
||||
(return (or (= (& end-index x) 0)
|
||||
(and (& multiline t)
|
||||
(character-set-member (nth (& str t) (- (& end-index x) 1)) line-terminators))))))
|
||||
(production :assertion (#\$) assertion-end
|
||||
((test-assertion (t r-e-input) (x r-e-match))
|
||||
(if (= (& end-index x) (length (& str t)))
|
||||
true
|
||||
(and (& multiline t)
|
||||
(character-set-member (nth (& str t) (& end-index x)) line-terminators)))))
|
||||
((test-assertion t x)
|
||||
(return (or (= (& end-index x) (length (& str t)))
|
||||
(and (& multiline t)
|
||||
(character-set-member (nth (& str t) (& end-index x)) line-terminators))))))
|
||||
(production :assertion (#\\ #\b) assertion-word-boundary
|
||||
((test-assertion (t r-e-input) (x r-e-match))
|
||||
(at-word-boundary (& end-index x) (& str t))))
|
||||
((test-assertion t x)
|
||||
(return (at-word-boundary (& end-index x) (& str t)))))
|
||||
(production :assertion (#\\ #\B) assertion-non-word-boundary
|
||||
((test-assertion (t r-e-input) (x r-e-match))
|
||||
(not (at-word-boundary (& end-index x) (& str t))))))
|
||||
((test-assertion t x)
|
||||
(return (not (at-word-boundary (& end-index x) (& str t)))))))
|
||||
|
||||
(%print-actions)
|
||||
|
||||
(define (at-word-boundary (i integer) (s string)) boolean
|
||||
(xor (in-word (- i 1) s) (in-word i s)))
|
||||
(return (xor (in-word (- i 1) s) (in-word i s))))
|
||||
|
||||
(define (in-word (i integer) (s string)) boolean
|
||||
(if (or (= i -1) (= i (length s)))
|
||||
false
|
||||
(character-set-member (nth s i) re-word-characters)))
|
||||
(return false)
|
||||
(return (character-set-member (nth s i) re-word-characters))))
|
||||
|
||||
|
||||
(%section "Atoms")
|
||||
|
||||
(rule :atom ((gen-matcher matcher-generator) (count-parens integer))
|
||||
(rule :atom ((gen-matcher (-> (integer) matcher)) (count-parens integer))
|
||||
(production :atom (:pattern-character) atom-pattern-character
|
||||
((gen-matcher (paren-index integer :unused))
|
||||
(character-matcher ($default-action :pattern-character)))
|
||||
((gen-matcher (paren-index :unused))
|
||||
(return (character-matcher ($default-action :pattern-character))))
|
||||
(count-parens 0))
|
||||
(production :atom (#\.) atom-dot
|
||||
((gen-matcher (paren-index integer :unused))
|
||||
(function ((t r-e-input) (x r-e-match) (c continuation))
|
||||
((character-set-matcher (if (& span t) (set-of character) line-terminators) true) t x c)))
|
||||
((gen-matcher (paren-index :unused))
|
||||
(function (m1 (t r-e-input) (x r-e-match) (c continuation)) r-e-result
|
||||
(var a (set character) line-terminators)
|
||||
(when (& span t)
|
||||
(<- a (set-of character)))
|
||||
(const m2 matcher (character-set-matcher a true))
|
||||
(return (m2 t x c)))
|
||||
(return m1))
|
||||
(count-parens 0))
|
||||
(production :atom (:null-escape) atom-null-escape
|
||||
((gen-matcher (paren-index integer :unused))
|
||||
(function ((t r-e-input :unused) (x r-e-match) (c continuation))
|
||||
(c x)))
|
||||
((gen-matcher (paren-index :unused))
|
||||
(function (m (t r-e-input :unused) (x r-e-match) (c continuation)) r-e-result
|
||||
(return (c x)))
|
||||
(return m))
|
||||
(count-parens 0))
|
||||
(production :atom (#\\ :atom-escape) atom-atom-escape
|
||||
(gen-matcher (gen-matcher :atom-escape))
|
||||
(count-parens 0))
|
||||
(production :atom (:character-class) atom-character-class
|
||||
((gen-matcher (paren-index integer :unused))
|
||||
(let ((a (set character) (acceptance-set :character-class)))
|
||||
(character-set-matcher a (invert :character-class))))
|
||||
((gen-matcher (paren-index :unused))
|
||||
(const a (set character) (acceptance-set :character-class))
|
||||
(return (character-set-matcher a (invert :character-class))))
|
||||
(count-parens 0))
|
||||
(production :atom (#\( :disjunction #\)) atom-parentheses
|
||||
((gen-matcher (paren-index integer))
|
||||
(let ((match matcher ((gen-matcher :disjunction) (+ paren-index 1))))
|
||||
(function ((t r-e-input) (x r-e-match) (c continuation))
|
||||
(let ((d continuation
|
||||
(function ((y r-e-match))
|
||||
(let ((updated-captures (vector capture)
|
||||
(set-nth (& captures y) paren-index
|
||||
(oneof present (subseq (& str t) (& end-index x) (- (& end-index y) 1))))))
|
||||
(c (tuple r-e-match (& end-index y) updated-captures))))))
|
||||
(match t x d)))))
|
||||
((gen-matcher paren-index)
|
||||
(const m1 matcher ((gen-matcher :disjunction) (+ paren-index 1)))
|
||||
(function (m2 (t r-e-input) (x r-e-match) (c continuation)) r-e-result
|
||||
(function (d (y r-e-match)) r-e-result
|
||||
(const ref capture (tag present (subseq (& str t) (& end-index x) (- (& end-index y) 1))))
|
||||
(const updated-captures (vector capture)
|
||||
(set-nth (& captures y) paren-index ref))
|
||||
(return (c (tag re-match (& end-index y) updated-captures))))
|
||||
(return (m1 t x d)))
|
||||
(return m2))
|
||||
(count-parens (+ (count-parens :disjunction) 1)))
|
||||
(production :atom (#\( #\? #\: :disjunction #\)) atom-non-capturing-parentheses
|
||||
(gen-matcher (gen-matcher :disjunction))
|
||||
(count-parens (count-parens :disjunction)))
|
||||
(production :atom (#\( #\? #\= :disjunction #\)) atom-positive-lookahead
|
||||
((gen-matcher (paren-index integer))
|
||||
(let ((match matcher ((gen-matcher :disjunction) paren-index)))
|
||||
(function ((t r-e-input) (x r-e-match) (c continuation))
|
||||
;(let ((d continuation
|
||||
; (function ((y r-e-match))
|
||||
; (c (tuple r-e-match (& end-index x) (& captures y))))))
|
||||
; (match t x d)))))
|
||||
(case (match t x success-continuation)
|
||||
((success y r-e-match)
|
||||
(c (tuple r-e-match (& end-index x) (& captures y))))
|
||||
(failure (oneof failure))))))
|
||||
((gen-matcher paren-index)
|
||||
(const m1 matcher ((gen-matcher :disjunction) paren-index))
|
||||
(function (m2 (t r-e-input) (x r-e-match) (c continuation)) r-e-result
|
||||
;(function (d (y r-e-match)) r-e-result
|
||||
; (return (c (tag re-match (& end-index x) (& captures y)))))
|
||||
;(return (m1 t x d)))))
|
||||
(const y r-e-result (m1 t x success-continuation))
|
||||
(case y
|
||||
(:narrow r-e-match (return (c (tag re-match (& end-index x) (& captures y)))))
|
||||
(:select (tag failure) (return failure))))
|
||||
(return m2))
|
||||
(count-parens (count-parens :disjunction)))
|
||||
(production :atom (#\( #\? #\! :disjunction #\)) atom-negative-lookahead
|
||||
((gen-matcher (paren-index integer))
|
||||
(let ((match matcher ((gen-matcher :disjunction) paren-index)))
|
||||
(function ((t r-e-input) (x r-e-match) (c continuation))
|
||||
(case (match t x success-continuation)
|
||||
((success y r-e-match :unused) (oneof failure))
|
||||
(failure (c x))))))
|
||||
((gen-matcher paren-index)
|
||||
(const m1 matcher ((gen-matcher :disjunction) paren-index))
|
||||
(function (m2 (t r-e-input) (x r-e-match) (c continuation)) r-e-result
|
||||
(case (m1 t x success-continuation)
|
||||
(:select r-e-match (return failure))
|
||||
(:select (tag failure) (return (c x)))))
|
||||
(return m2))
|
||||
(count-parens (count-parens :disjunction))))
|
||||
|
||||
(%charclass :pattern-character)
|
||||
|
|
@ -400,39 +419,39 @@
|
|||
|
||||
(production :null-escape (#\\ #\_) null-escape-underscore)
|
||||
|
||||
(rule :atom-escape ((gen-matcher matcher-generator))
|
||||
(rule :atom-escape ((gen-matcher (-> (integer) matcher)))
|
||||
(production :atom-escape (:decimal-escape) atom-escape-decimal
|
||||
((gen-matcher (paren-index integer))
|
||||
(let ((n integer (escape-value :decimal-escape)))
|
||||
(if (= n 0)
|
||||
(character-matcher #?0000)
|
||||
(if (> n paren-index)
|
||||
(throw (oneof syntax-error))
|
||||
(backreference-matcher n))))))
|
||||
((gen-matcher paren-index)
|
||||
(const n integer (escape-value :decimal-escape))
|
||||
(cond
|
||||
((= n 0) (return (character-matcher #?0000)))
|
||||
((> n paren-index) (throw syntax-error))
|
||||
(nil (return (backreference-matcher n))))))
|
||||
(production :atom-escape (:character-escape) atom-escape-character
|
||||
((gen-matcher (paren-index integer :unused))
|
||||
(character-matcher (character-value :character-escape))))
|
||||
((gen-matcher (paren-index :unused))
|
||||
(return (character-matcher (character-value :character-escape)))))
|
||||
(production :atom-escape (:character-class-escape) atom-escape-character-class
|
||||
((gen-matcher (paren-index integer :unused))
|
||||
(character-set-matcher (acceptance-set :character-class-escape) false))))
|
||||
((gen-matcher (paren-index :unused))
|
||||
(return (character-set-matcher (acceptance-set :character-class-escape) false)))))
|
||||
(%print-actions)
|
||||
|
||||
(define (backreference-matcher (n integer)) matcher
|
||||
(function ((t r-e-input) (x r-e-match) (c continuation))
|
||||
(case (nth-backreference x n)
|
||||
((present ref string)
|
||||
(let ((i integer (& end-index x))
|
||||
(s string (& str t)))
|
||||
(let ((j integer (+ i (length ref))))
|
||||
(if (> j (length s))
|
||||
(oneof failure)
|
||||
(if (string= (subseq s i (- j 1)) ref) ;*********ignore case?
|
||||
(c (tuple r-e-match j (& captures x)))
|
||||
(oneof failure))))))
|
||||
(absent (c x)))))
|
||||
(function (m (t r-e-input) (x r-e-match) (c continuation)) r-e-result
|
||||
(const ref capture (nth-backreference x n))
|
||||
(case ref
|
||||
(:narrow (tag present)
|
||||
(const i integer (& end-index x))
|
||||
(const s string (& str t))
|
||||
(const j integer (+ i (length (& s ref))))
|
||||
(if (and (<= j (length s))
|
||||
(= (subseq s i (- j 1)) (& s ref) string)) ;*********ignore case?
|
||||
(return (c (tag re-match j (& captures x))))
|
||||
(return failure)))
|
||||
(:select (tag absent) (return (c x)))))
|
||||
(return m))
|
||||
|
||||
(define (nth-backreference (x r-e-match) (n integer)) capture
|
||||
(nth (& captures x) (- n 1)))
|
||||
(return (nth (& captures x) (- n 1))))
|
||||
|
||||
|
||||
(rule :character-escape ((character-value character))
|
||||
|
|
@ -539,21 +558,20 @@
|
|||
(acceptance-set :nonempty-class-ranges))))
|
||||
(production (:nonempty-class-ranges :delta) ((:class-atom :delta) #\- (:class-atom dash) :class-ranges) nonempty-class-ranges-range
|
||||
(acceptance-set
|
||||
(let ((range (set character) (character-range (acceptance-set :class-atom 1)
|
||||
(acceptance-set :class-atom 2))))
|
||||
(character-set-union range (acceptance-set :class-ranges)))))
|
||||
(character-set-union (character-range (acceptance-set :class-atom 1) (acceptance-set :class-atom 2))
|
||||
(acceptance-set :class-ranges))))
|
||||
(production (:nonempty-class-ranges :delta) (:null-escape :class-ranges) nonempty-class-ranges-null-escape
|
||||
(acceptance-set (acceptance-set :class-ranges))))
|
||||
(%print-actions)
|
||||
|
||||
(define (character-range (low (set character)) (high (set character))) (set character)
|
||||
(if (or (/= (character-set-length low) 1) (/= (character-set-length high) 1))
|
||||
(throw (oneof syntax-error))
|
||||
(let ((l character (character-set-min low))
|
||||
(h character (character-set-min high)))
|
||||
(if (char<= l h)
|
||||
(set-of-ranges character l h)
|
||||
(throw (oneof syntax-error))))))
|
||||
(rwhen (or (/= (character-set-length low) 1) (/= (character-set-length high) 1))
|
||||
(throw syntax-error))
|
||||
(const l character (character-set-min low))
|
||||
(const h character (character-set-min high))
|
||||
(if (<= l h character)
|
||||
(return (set-of-ranges character l h))
|
||||
(throw syntax-error)))
|
||||
|
||||
|
||||
(%subsection "Character Class Range Atoms")
|
||||
|
|
@ -570,9 +588,10 @@
|
|||
(rule :class-escape ((acceptance-set (set character)))
|
||||
(production :class-escape (:decimal-escape) class-escape-decimal
|
||||
(acceptance-set
|
||||
(if (= (escape-value :decimal-escape) 0)
|
||||
(set-of character #?0000)
|
||||
(throw (oneof syntax-error)))))
|
||||
(begin
|
||||
(if (= (escape-value :decimal-escape) 0)
|
||||
(return (set-of character #?0000))
|
||||
(throw syntax-error)))))
|
||||
(production :class-escape (#\b) class-escape-backspace
|
||||
(acceptance-set (set-of character #?0008)))
|
||||
(production :class-escape (:character-escape) class-escape-character-escape
|
||||
|
|
@ -586,43 +605,41 @@
|
|||
(defparameter *rg* (lexer-grammar *rl*)))
|
||||
|
||||
|
||||
(defun run-regexp (regexp input &key ignore-case multiline span)
|
||||
(let ((exec (first (lexer-parse *rl* regexp))))
|
||||
(dotimes (i (length input) '(failure))
|
||||
(let ((result (funcall exec (list input ignore-case multiline span) i)))
|
||||
(ecase (first result)
|
||||
(success
|
||||
(return (list* i (subseq input i (second result)) (cddr result))))
|
||||
(failure))))))
|
||||
(eval-when (:load-toplevel :execute)
|
||||
(defun run-regexp (regexp input &key ignore-case multiline span)
|
||||
(let ((execute (first (lexer-parse *rl* regexp))))
|
||||
(dotimes (i (length input) :failure)
|
||||
(let ((result (funcall execute (list 'r:re-input input ignore-case multiline span) i)))
|
||||
(unless (eq result :failure)
|
||||
(assert-true (eq (first result) 'r:re-match))
|
||||
(return (list* i (subseq input i (second result)) (cddr result)))))))))
|
||||
|
||||
#|
|
||||
(values
|
||||
(depict-rtf-to-local-file
|
||||
"JS20/RegExpGrammar.rtf"
|
||||
"Regular Expression Grammar"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *rw* :visible-semantics nil)))
|
||||
(depict-rtf-to-local-file
|
||||
"JS20/RegExpSemantics.rtf"
|
||||
"Regular Expression Semantics"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *rw*))))
|
||||
|
||||
(values
|
||||
(depict-html-to-local-file
|
||||
"JS20/RegExpGrammar.html"
|
||||
"Regular Expression Grammar"
|
||||
t
|
||||
#'(lambda (html-stream)
|
||||
(depict-world-commands html-stream *rw* :visible-semantics nil))
|
||||
:external-link-base "notation.html")
|
||||
(depict-html-to-local-file
|
||||
"JS20/RegExpSemantics.html"
|
||||
"Regular Expression Semantics"
|
||||
t
|
||||
#'(lambda (html-stream)
|
||||
(depict-world-commands html-stream *rw*))
|
||||
:external-link-base "notation.html"))
|
||||
(depict-rtf-to-local-file
|
||||
"JS20/RegExpGrammar.rtf"
|
||||
"Regular Expression Grammar"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *rw* :visible-semantics nil)))
|
||||
(depict-rtf-to-local-file
|
||||
"JS20/RegExpSemantics.rtf"
|
||||
"Regular Expression Semantics"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *rw*)))
|
||||
(depict-html-to-local-file
|
||||
"JS20/RegExpGrammar.html"
|
||||
"Regular Expression Grammar"
|
||||
t
|
||||
#'(lambda (html-stream)
|
||||
(depict-world-commands html-stream *rw* :visible-semantics nil))
|
||||
:external-link-base "notation.html")
|
||||
(depict-html-to-local-file
|
||||
"JS20/RegExpSemantics.html"
|
||||
"Regular Expression Semantics"
|
||||
t
|
||||
#'(lambda (html-stream)
|
||||
(depict-world-commands html-stream *rw*))
|
||||
:external-link-base "notation.html"))
|
||||
|
||||
(with-local-output (s "JS20/RegExpGrammar.txt") (print-lexer *rl* s) (print-grammar *rg* s))
|
||||
|
||||
|
|
@ -630,6 +647,7 @@
|
|||
(lexer-pparse *rl* "[]+" :trace t)
|
||||
(run-regexp "(0x|0)2" "0x20")
|
||||
(run-regexp "(a*)b\\1+c" "aabaaaac")
|
||||
(run-regexp "(a*)b\\1+c" "aabaabaaaac")
|
||||
(run-regexp "(a*)b\\1+" "baaaac")
|
||||
(run-regexp "b(a+)(a+)?(a+)c" "baaaac")
|
||||
(run-regexp "(((a+)?(b+)?c)*)" "aacbbbcac")
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
;;;
|
||||
;;; JavaScript 2.0 lexer
|
||||
;;; JavaScript 2.0 unit lexer
|
||||
;;;
|
||||
;;; Waldemar Horwat (waldemar@acm.org)
|
||||
;;;
|
||||
|
|
@ -41,7 +41,6 @@
|
|||
|
||||
(%text nil "The start nonterminal is " (:grammar-symbol :unit-pattern) ".")
|
||||
|
||||
(deftype semantic-exception (oneof syntax-error))
|
||||
(%print-actions)
|
||||
|
||||
|
||||
|
|
@ -86,18 +85,16 @@
|
|||
(production (:unit-factor :sigma) (#\1 (:white-space wsopt) #\^ (:white-space wsopt) :signed-integer (:white-space :sigma)) unit-factor-one-exponent
|
||||
(value (vector-of unit-factor)))
|
||||
(production (:unit-factor :sigma) (:identifier (:white-space :sigma)) unit-factor-identifier
|
||||
(value (vector (tuple unit-factor (name :identifier) 1))))
|
||||
(value (vector (tag unit-factor (name :identifier) 1))))
|
||||
(production (:unit-factor :sigma) (:identifier (:white-space wsopt) #\^ (:white-space wsopt) :signed-integer (:white-space :sigma)) unit-factor-identifier-exponent
|
||||
(value (vector (tuple unit-factor (name :identifier) (integer-value :signed-integer))))))
|
||||
(value (vector (tag unit-factor (name :identifier) (integer-value :signed-integer))))))
|
||||
|
||||
(deftag unit-factor (identifier string) (exponent integer))
|
||||
(deftype unit-factor (tag unit-factor))
|
||||
(deftype unit-list (vector unit-factor))
|
||||
(deftype unit-factor (tuple (identifier string) (exponent integer)))
|
||||
|
||||
(define (unit-reciprocal (u unit-list)) unit-list
|
||||
(if (empty u)
|
||||
(vector-of unit-factor)
|
||||
(let ((f unit-factor (nth u 0)))
|
||||
(append (vector (tuple unit-factor (& identifier f) (neg (& exponent f)))) (subseq u 1)))))
|
||||
(define (unit-reciprocal (value unit-list)) unit-list
|
||||
(return (map value f (tag unit-factor (& identifier f) (neg (& exponent f))))))
|
||||
|
||||
(%print-actions)
|
||||
|
||||
|
|
@ -146,41 +143,39 @@
|
|||
"JS20/UnitCharClasses.rtf"
|
||||
"JavaScript 2 Unit Character Classes"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-paragraph (rtf-stream ':grammar-header)
|
||||
(depict-paragraph (rtf-stream :grammar-header)
|
||||
(depict rtf-stream "Character Classes"))
|
||||
(dolist (charclass (lexer-charclasses *ul*))
|
||||
(depict-charclass rtf-stream charclass))
|
||||
(depict-paragraph (rtf-stream ':grammar-header)
|
||||
(depict-paragraph (rtf-stream :grammar-header)
|
||||
(depict rtf-stream "Grammar"))
|
||||
(depict-grammar rtf-stream *ug*)))
|
||||
|
||||
(values
|
||||
(depict-rtf-to-local-file
|
||||
"JS20/UnitGrammar.rtf"
|
||||
"JavaScript 2 Unit Grammar"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *uw* :visible-semantics nil)))
|
||||
(depict-rtf-to-local-file
|
||||
"JS20/UnitSemantics.rtf"
|
||||
"JavaScript 2 Unit Semantics"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *uw*))))
|
||||
|
||||
(values
|
||||
(depict-html-to-local-file
|
||||
"JS20/UnitGrammar.html"
|
||||
"JavaScript 2 Unit Grammar"
|
||||
t
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *uw* :visible-semantics nil))
|
||||
:external-link-base "notation.html")
|
||||
(depict-html-to-local-file
|
||||
"JS20/UnitSemantics.html"
|
||||
"JavaScript 2 Unit Semantics"
|
||||
t
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *uw*))
|
||||
:external-link-base "notation.html"))
|
||||
(depict-rtf-to-local-file
|
||||
"JS20/UnitGrammar.rtf"
|
||||
"JavaScript 2 Unit Grammar"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *uw* :visible-semantics nil)))
|
||||
(depict-rtf-to-local-file
|
||||
"JS20/UnitSemantics.rtf"
|
||||
"JavaScript 2 Unit Semantics"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *uw*)))
|
||||
(depict-html-to-local-file
|
||||
"JS20/UnitGrammar.html"
|
||||
"JavaScript 2 Unit Grammar"
|
||||
t
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *uw* :visible-semantics nil))
|
||||
:external-link-base "notation.html")
|
||||
(depict-html-to-local-file
|
||||
"JS20/UnitSemantics.html"
|
||||
"JavaScript 2 Unit Semantics"
|
||||
t
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *uw*))
|
||||
:external-link-base "notation.html"))
|
||||
|
||||
(with-local-output (s "JS20/UnitGrammar.txt") (print-lexer *ul* s) (print-grammar *ug* s))
|
||||
|
||||
|
|
|
|||
|
|
@ -308,24 +308,24 @@
|
|||
|
||||
; Emit markup paragraphs for the lexer charclass.
|
||||
(defun depict-charclass (markup-stream charclass)
|
||||
(depict-block-style (markup-stream ':grammar-rule)
|
||||
(depict-block-style (markup-stream :grammar-rule)
|
||||
(let ((nonterminal (charclass-nonterminal charclass))
|
||||
(expr (charclass-charset-source charclass)))
|
||||
(if (and (consp expr) (eq (first expr) '++))
|
||||
(let* ((subexprs (rest expr))
|
||||
(length (length subexprs)))
|
||||
(depict-paragraph (markup-stream ':grammar-lhs)
|
||||
(depict-paragraph (markup-stream :grammar-lhs)
|
||||
(depict-general-nonterminal markup-stream nonterminal :definition)
|
||||
(depict markup-stream " " ':derives-10))
|
||||
(depict markup-stream " " :derives-10))
|
||||
(dotimes (i length)
|
||||
(depict-paragraph (markup-stream (if (= i (1- length)) ':grammar-rhs-last ':grammar-rhs))
|
||||
(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 markup-stream :tab3)
|
||||
(depict markup-stream "|" :tab2))
|
||||
(depict-charset-source markup-stream (nth i subexprs)))))
|
||||
(depict-paragraph (markup-stream ':grammar-lhs-last)
|
||||
(depict-paragraph (markup-stream :grammar-lhs-last)
|
||||
(depict-general-nonterminal markup-stream (charclass-nonterminal charclass) :definition)
|
||||
(depict markup-stream " " ':derives-10 " ")
|
||||
(depict markup-stream " " :derives-10 " ")
|
||||
(depict-charset-source markup-stream expr))))))
|
||||
|
||||
|
||||
|
|
@ -589,10 +589,10 @@
|
|||
#'(lambda (component)
|
||||
(when (consp component)
|
||||
(let ((tag (first component)))
|
||||
(when (eq tag ':-)
|
||||
(setq component (list* ':-- (rest component) (rest component)))
|
||||
(setq tag ':--))
|
||||
(when (eq tag ':--)
|
||||
(when (eq tag :-)
|
||||
(setq component (list* :-- (rest component) (rest component)))
|
||||
(setq tag :--))
|
||||
(when (eq tag :--)
|
||||
(setq component
|
||||
(list* tag
|
||||
(second component)
|
||||
|
|
@ -638,7 +638,7 @@
|
|||
(production-number 0))
|
||||
(dolist (action (charclass-actions charclass))
|
||||
(let ((lexer-action (cdr action)))
|
||||
(push (list 'declare-action (car action) nonterminal-source (lexer-action-type-expr lexer-action)) commands)))
|
||||
(push (list 'declare-action (car action) nonterminal-source (lexer-action-type-expr lexer-action) 1) commands)))
|
||||
(do ((charset (charclass-charset charclass)))
|
||||
((charset-empty? charset))
|
||||
(let* ((partition-name (if (charset-infinite? charset)
|
||||
|
|
@ -661,7 +661,7 @@
|
|||
((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)))
|
||||
(push (list 'action (car action) production-name (lexer-action-type-expr lexer-action) 1 body) commands)))
|
||||
(setq charset (charset-difference charset partition-charset)))))))
|
||||
|
||||
(let ((partition-commands
|
||||
|
|
@ -670,7 +670,7 @@
|
|||
(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 'declare-action lexer-action-name partition-name (lexer-action-type-expr lexer-action) 1)
|
||||
(list 'terminal-action lexer-action-name partition-name (lexer-action-function lexer-action)))))
|
||||
(partition-lexer-actions (gethash partition-name (lexer-partitions lexer)))))
|
||||
(lexer-partition-names lexer))))
|
||||
|
|
|
|||
|
|
@ -52,7 +52,7 @@
|
|||
(push (if (equal dir-name "..") :up dir-name) directories)
|
||||
(setq filename (subseq filename (1+ slash))))
|
||||
(return (if directories
|
||||
(make-pathname :directory (cons ':relative (nreverse directories)) :name filename #+lispworks :type #+lispworks "lisp")
|
||||
(make-pathname :directory (cons :relative (nreverse directories)) :name filename #+lispworks :type #+lispworks "lisp")
|
||||
#-lispworks filename
|
||||
#+lispworks (make-pathname :name filename :type "lisp"))))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -197,8 +197,9 @@
|
|||
(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
|
||||
(defstruct (soft-break (:constructor make-soft-break (width groups)))
|
||||
(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
|
||||
(groups nil :type list)) ;List of groups to be added to the new line if a line break happens here
|
||||
|
||||
|
||||
; Destructively replace any soft-break that appears in a car position in the tree with
|
||||
|
|
@ -231,18 +232,20 @@
|
|||
; Return a freshly consed markup list for a hard line break followed by indent spaces.
|
||||
(defun hard-break-markup (indent)
|
||||
(if (zerop indent)
|
||||
(list ':new-line)
|
||||
(list ':new-line (make-string indent :initial-element #\space :element-type #-mcl 'character #+mcl 'base-character))))
|
||||
(list :new-line)
|
||||
(list :new-line (make-string indent :initial-element #\space :element-type #-mcl 'character #+mcl 'base-character))))
|
||||
|
||||
|
||||
; Destructively replace any soft-break that appears in a car position in the tree
|
||||
; with a line break followed by indent spaces.
|
||||
; Note that if the markup-stream's tail was pointing to a soft break, it may now not point
|
||||
; to the last cons cell of the tree and should be adjusted.
|
||||
(defun expand-soft-breaks (tree indent)
|
||||
(substitute-soft-breaks
|
||||
tree
|
||||
#'(lambda (soft-break)
|
||||
(declare (ignore soft-break))
|
||||
(hard-break-markup indent))))
|
||||
(nconc (hard-break-markup indent)
|
||||
(copy-list (soft-break-groups soft-break))))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
|
|
@ -451,7 +454,7 @@
|
|||
(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))))
|
||||
(markup-stream-append1 markup-stream (list :invisible (format nil "<~D" indent))))
|
||||
(prog1
|
||||
(funcall emitter markup-stream)
|
||||
(when *show-logical-blocks*
|
||||
|
|
@ -479,8 +482,10 @@
|
|||
(remove-soft-breaks tree)
|
||||
(incf (logical-position-position logical-position) inner-count))
|
||||
(t
|
||||
(assert-true tree)
|
||||
(expand-soft-breaks tree cumulative-indent)
|
||||
(let ((tail (markup-stream-tail markup-stream)))
|
||||
(assert-true (and tree (consp tail) (null (cdr tail))))
|
||||
(expand-soft-breaks tree cumulative-indent)
|
||||
(setf (markup-stream-tail markup-stream) (assert-non-null (last tail))))
|
||||
(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))))
|
||||
|
|
@ -503,15 +508,20 @@
|
|||
; 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.
|
||||
; If the line break is needed, the new line is indented to the current indent level and groups,
|
||||
; if provided, are added to the beginning of the new line. The width of these groups is currently not taken
|
||||
; into account.
|
||||
; Must be called from the dynamic scope of a depict-logical-block.
|
||||
(defun depict-break (markup-stream &optional (width t))
|
||||
(defun depict-break (markup-stream &optional (width t) &rest groups)
|
||||
(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
|
||||
(depict-item-or-list markup-stream (hard-break-markup indent))
|
||||
(dolist (item groups)
|
||||
(markup-stream-append1 markup-stream item)))
|
||||
(progn
|
||||
(incf (logical-position-n-soft-breaks logical-position))
|
||||
(incf (logical-position-position logical-position) width)
|
||||
|
|
@ -521,7 +531,7 @@
|
|||
(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)))))))
|
||||
(markup-stream-append1 markup-stream (make-soft-break width groups)))))))
|
||||
|
||||
|
||||
; Call emitter to emit each element of the given list onto the markup-stream.
|
||||
|
|
@ -554,7 +564,7 @@
|
|||
(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"))
|
||||
((eq empty :error) (error "Non-empty list required"))
|
||||
(t (depict-item-or-list markup-stream empty)))
|
||||
(depict-item-or-list markup-stream suffix)))
|
||||
|
||||
|
|
@ -580,21 +590,21 @@
|
|||
(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)
|
||||
(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))))))
|
||||
(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)
|
||||
(depict markup-stream :left-double-quote)
|
||||
(unless (equal string "")
|
||||
(depict-char-style (markup-stream ':character-literal)
|
||||
(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))
|
||||
(depict markup-stream :right-double-quote))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
|
|
@ -668,6 +678,9 @@
|
|||
|
||||
; Emit markup for the given integer, displaying it in decimal.
|
||||
(defun depict-integer (markup-stream i)
|
||||
(when (minusp i)
|
||||
(depict markup-stream :minus)
|
||||
(setq i (- i)))
|
||||
(depict markup-stream (format nil "~D" i)))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -667,7 +667,6 @@
|
|||
#'(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))))
|
||||
|
||||
|
|
@ -736,7 +735,7 @@
|
|||
|
||||
; 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)
|
||||
(defun define-action (grammar production-name action-symbol type action-expr)
|
||||
(dolist (production (general-production-productions (grammar-general-production grammar production-name)))
|
||||
(let ((definition (assoc action-symbol (production-actions production) :test #'eq)))
|
||||
(cond
|
||||
|
|
@ -744,7 +743,7 @@
|
|||
(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)))))))
|
||||
(t (setf (cdr definition) (make-action type action-expr)))))))
|
||||
|
||||
|
||||
; Define action action-symbol, when called on the given terminal,
|
||||
|
|
|
|||
|
|
@ -124,12 +124,15 @@
|
|||
((:infinity 1) u 8734 \' 176)
|
||||
((:left-single-quote 1) lquote)
|
||||
((:right-single-quote 1) rquote)
|
||||
((:apostrophe 1) rquote)
|
||||
((:left-double-quote 1) ldblquote)
|
||||
((:right-double-quote 1) rdblquote)
|
||||
((:left-angle-quote 1) u 171 \' 199)
|
||||
((:right-angle-quote 1) u 187 \' 200)
|
||||
((:for-all-10 1) (field (* fldinst "SYMBOL 34 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:exists-10 1) (field (* fldinst "SYMBOL 36 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:bottom-10 1) (field (* fldinst "SYMBOL 94 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:vector-assign-10 2) (field (* fldinst "SYMBOL 172 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:assign-10 2) (field (* fldinst "SYMBOL 172 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:up-arrow-10 1) (field (* fldinst "SYMBOL 173 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:function-arrow-10 2) (field (* fldinst "SYMBOL 174 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:cartesian-product-10 2) (field (* fldinst "SYMBOL 180 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
|
|
@ -140,9 +143,14 @@
|
|||
((:union-10 1) (field (* fldinst "SYMBOL 200 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:member-10 2) (field (* fldinst "SYMBOL 206 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:not-member-10 2) (field (* fldinst "SYMBOL 207 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:label-assign-10 2) (field (* fldinst "SYMBOL 220 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:derives-10 2) (field (* fldinst "SYMBOL 222 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:left-triangle-bracket-10 1) (field (* fldinst "SYMBOL 225 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:left-ceiling-10 1) (field (* fldinst "SYMBOL 233 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:left-floor-10 1) (field (* fldinst "SYMBOL 235 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:right-triangle-bracket-10 1) (field (* fldinst "SYMBOL 241 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:right-ceiling-10 1) (field (* fldinst "SYMBOL 249 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:right-floor-10 1) (field (* fldinst "SYMBOL 251 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:big-plus-10 2) (field (* fldinst "SYMBOL 58 \\f \"Zapf Dingbats\" \\s 10") (fldrslt :zapf-dingbats :10-pt)))
|
||||
|
||||
((:alpha 1) (field (* fldinst "SYMBOL 97 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
|
|
@ -285,21 +293,25 @@
|
|||
|
||||
(: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;"))
|
||||
((+ :styles) (* :type-name additive sbasedon :default-paragraph-font-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;"))
|
||||
(:field-name cs :field-name-num :helvetica :no-language)
|
||||
((+ :styles) (* :field-name additive sbasedon :default-paragraph-font-num "Field Name;"))
|
||||
|
||||
(:global-variable-num 44)
|
||||
(:tag-name-num 44)
|
||||
(:tag-name cs :tag-name-num :helvetica b :no-language)
|
||||
((+ :styles) (* :tag-name additive sbasedon :default-paragraph-font-num "Tag Name;"))
|
||||
|
||||
(:global-variable-num 45)
|
||||
(:global-variable cs :global-variable-num i :times :dark-green :no-language)
|
||||
((+ :styles) (* :global-variable additive sbasedon :default-paragraph-font-num "Global Variable;"))
|
||||
|
||||
(:local-variable-num 45)
|
||||
(:local-variable-num 46)
|
||||
(:local-variable cs :local-variable-num i :times :green :no-language)
|
||||
((+ :styles) (* :local-variable additive sbasedon :default-paragraph-font-num "Local Variable;"))
|
||||
|
||||
(:action-name-num 46)
|
||||
(:action-name-num 47)
|
||||
(:action-name cs :action-name-num :zapf-chancery :purple :no-language)
|
||||
((+ :styles) (* :action-name additive sbasedon :default-paragraph-font-num "Action Name;"))
|
||||
|
||||
|
|
@ -344,6 +356,8 @@
|
|||
((:vector-append 2) :circle-plus-10)
|
||||
((:tuple-begin 1) (b :left-triangle-bracket-10))
|
||||
((:tuple-end 1) (b :right-triangle-bracket-10))
|
||||
((:record-begin 1) (b :left-triangle-bracket-10 :left-triangle-bracket-10))
|
||||
((:record-end 1) (b :right-triangle-bracket-10 :right-triangle-bracket-10))
|
||||
((:true 4) (:global-variable "true"))
|
||||
((:false 5) (:global-variable "false"))
|
||||
((:unique 6) (:semantic-keyword "unique"))
|
||||
|
|
@ -445,12 +459,15 @@
|
|||
((:infinity 1) u 8734 \' 176)
|
||||
((:left-single-quote 1) lquote)
|
||||
((:right-single-quote 1) rquote)
|
||||
((:apostrophe 1) rquote)
|
||||
((:left-double-quote 1) ldblquote)
|
||||
((:right-double-quote 1) rdblquote)
|
||||
((:left-angle-quote 1) u 171 \' 199)
|
||||
((:right-angle-quote 1) u 187 \' 200)
|
||||
((:for-all-10 1) (field (* fldinst "SYMBOL 34 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:exists-10 1) (field (* fldinst "SYMBOL 36 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:bottom-10 1) (field (* fldinst "SYMBOL 94 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:vector-assign-10 2) (field (* fldinst "SYMBOL 172 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:assign-10 2) (field (* fldinst "SYMBOL 172 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:up-arrow-10 1) (field (* fldinst "SYMBOL 173 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:function-arrow-10 2) (field (* fldinst "SYMBOL 174 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:cartesian-product-10 2) (field (* fldinst "SYMBOL 180 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
|
|
@ -461,9 +478,14 @@
|
|||
((:union-10 1) (field (* fldinst "SYMBOL 200 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:member-10 2) (field (* fldinst "SYMBOL 206 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:not-member-10 2) (field (* fldinst "SYMBOL 207 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:label-assign-10 2) (field (* fldinst "SYMBOL 220 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:derives-10 2) (field (* fldinst "SYMBOL 222 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:left-triangle-bracket-10 1) (field (* fldinst "SYMBOL 225 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:left-ceiling-10 1) (field (* fldinst "SYMBOL 233 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:left-floor-10 1) (field (* fldinst "SYMBOL 235 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:right-triangle-bracket-10 1) (field (* fldinst "SYMBOL 241 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:right-ceiling-10 1) (field (* fldinst "SYMBOL 249 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:right-floor-10 1) (field (* fldinst "SYMBOL 251 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
((:big-plus-10 2) (field (* fldinst "SYMBOL 58 \\f \"Zapf Dingbats\" \\s 10") (fldrslt :zapf-dingbats :10-pt)))
|
||||
|
||||
((:alpha 1) (field (* fldinst "SYMBOL 97 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
|
||||
|
|
@ -600,27 +622,33 @@
|
|||
|
||||
(: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;"))
|
||||
((+ :styles) (* :type-name additive sbasedon :default-paragraph-font-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;"))
|
||||
(:field-name cs :field-name-num :helvetica :no-language)
|
||||
((+ :styles) (* :field-name additive sbasedon :default-paragraph-font-num "Field Name;"))
|
||||
|
||||
(:global-variable-num 44)
|
||||
(:tag-name-num 44)
|
||||
(:tag-name cs :tag-name-num :helvetica b :no-language)
|
||||
((+ :styles) (* :tag-name additive sbasedon :default-paragraph-font-num "Tag Name;"))
|
||||
|
||||
(:global-variable-num 45)
|
||||
(:global-variable cs :global-variable-num i :times :dark-green :no-language)
|
||||
((+ :styles) (* :global-variable additive sbasedon :default-paragraph-font-num "Global Variable;"))
|
||||
|
||||
(:local-variable-num 45)
|
||||
(:local-variable-num 46)
|
||||
(:local-variable cs :local-variable-num i :times :green :no-language)
|
||||
((+ :styles) (* :local-variable additive sbasedon :default-paragraph-font-num "Local Variable;"))
|
||||
|
||||
(:action-name-num 46)
|
||||
(:action-name-num 47)
|
||||
(:action-name cs :action-name-num :zapf-chancery :purple :no-language)
|
||||
((+ :styles) (* :action-name additive sbasedon :default-paragraph-font-num "Action Name;"))
|
||||
|
||||
(:id-name-num 47)
|
||||
#|
|
||||
(:id-name-num 48)
|
||||
(:id-name cs :id-name-num scaps :helvetica :no-language)
|
||||
((+ :styles) (* :id-name additive sbasedon :default-paragraph-font-num "Id Name;"))
|
||||
|#
|
||||
|
||||
|
||||
(:variable-num 50)
|
||||
|
|
@ -1059,14 +1087,14 @@
|
|||
(let* ((top-rtf-stream (make-top-level-rtf-stream rtf-definitions))
|
||||
(rtf-stream (make-rtf-stream (markup-stream-env top-rtf-stream) *markup-stream-paragraph-level*))
|
||||
(time (get-universal-time)))
|
||||
(markup-stream-append1 rtf-stream ':rtf-intro)
|
||||
(markup-stream-append1 rtf-stream :rtf-intro)
|
||||
(let ((info (generate-document-info title *rtf-author* *rtf-company* time)))
|
||||
(when info
|
||||
(markup-stream-append1 rtf-stream info)))
|
||||
(markup-stream-append1 rtf-stream ':docfmt)
|
||||
(markup-stream-append1 rtf-stream ':reset-section)
|
||||
(markup-stream-append1 rtf-stream :docfmt)
|
||||
(markup-stream-append1 rtf-stream :reset-section)
|
||||
(markup-stream-append1 rtf-stream (generate-header-group title time))
|
||||
(markup-stream-append1 rtf-stream ':footer-group)
|
||||
(markup-stream-append1 rtf-stream :footer-group)
|
||||
(funcall emitter rtf-stream)
|
||||
(markup-stream-append1 top-rtf-stream (markup-stream-unexpanded-output rtf-stream))
|
||||
top-rtf-stream))
|
||||
|
|
@ -1098,7 +1126,7 @@
|
|||
(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 :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*)
|
||||
|
|
@ -1108,7 +1136,7 @@
|
|||
(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)))
|
||||
(markup-stream-append1 rtf-stream :new-paragraph)))
|
||||
|
||||
|
||||
(defmethod depict-char-style-f ((rtf-stream rtf-stream) char-style emitter)
|
||||
|
|
|
|||
Загрузка…
Ссылка в новой задаче