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

Switchover to Algol-style semantics

This commit is contained in:
waldemar%netscape.com 2001-04-12 04:31:46 +00:00
Родитель 95b05408c4
Коммит dacc51531a
14 изменённых файлов: 4403 добавлений и 3010 удалений
Показать статистику Скачать Patch файл Скачать Diff файл Показать все файлы Свернуть все файлы

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

Разница между файлами не показана из-за своего большого размера Загрузить разницу

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

Разница между файлами не показана из-за своего большого размера Загрузить разницу

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

@ -152,8 +152,9 @@
;;; the values returned by the rhs's last grammar symbol's actions, in order of the ;;; the values returned by the rhs's last grammar symbol's actions, in order of the
;;; actions of that grammar symbol. ;;; actions of that grammar symbol.
;;; Function f returns one value, which is the result of this action. ;;; 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?)) (: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 (expr nil :read-only t) ;The unparsed source expression that defines the action
(code nil)) ;The generated lisp source code that performs 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. ; Emit a markup paragraph for the left-hand-side of a general production.
(defun depict-general-production-lhs (markup-stream lhs-general-nonterminal) (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-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. ; 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. ; first is true if this is the first production in a rule.
; last is true if this is the last 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) (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 (if first
(depict markup-stream ':tab3) (depict markup-stream :tab3)
(depict markup-stream "|" ':tab2)) (depict markup-stream "|" :tab2))
(let ((rhs-components (general-production-rhs-components general-production))) (let ((rhs-components (general-production-rhs-components general-production)))
(depict-list markup-stream (depict-list markup-stream
#'depict-production-rhs-component #'depict-production-rhs-component
@ -301,7 +302,7 @@
(let ((lhs (general-production-lhs general-production)) (let ((lhs (general-production-lhs general-production))
(rhs-components (general-production-rhs-components general-production))) (rhs-components (general-production-rhs-components general-production)))
(depict-general-nonterminal markup-stream lhs link) (depict-general-nonterminal markup-stream lhs link)
(depict markup-stream " " ':derives-10) (depict markup-stream " " :derives-10)
(if rhs-components (if rhs-components
(let ((counts-hash (make-hash-table :test *grammar-symbol-=*))) (let ((counts-hash (make-hash-table :test *grammar-symbol-=*)))
(when symbols-with-subscripts (when symbols-with-subscripts
@ -326,7 +327,7 @@
(setq subscript (incf (gethash symbol counts-hash)))))) (setq subscript (incf (gethash symbol counts-hash))))))
(depict-space markup-stream) (depict-space markup-stream)
(depict-production-rhs-component markup-stream production-rhs-component subscript)))) (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 (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 ; ; 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 (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 (evaluator nil :type (or null function))) ;The lisp evaluator of the action
@ -474,7 +474,7 @@
(rule-highlight (and (endp (rest production-runs)) (rule-highlight (and (endp (rest production-runs))
(check-highlight (first (first production-runs)) highlights markup-stream)))) (check-highlight (first (first production-runs)) highlights markup-stream))))
(depict-block-style (markup-stream rule-highlight t) (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) (if (rest general-productions)
(progn (progn
(depict-general-production-lhs markup-stream (general-rule-lhs general-rule)) (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) (depict-block-style (markup-stream (check-highlight (first production-run) highlights markup-stream) t)
(dolist (p (rest production-run)) (dolist (p (rest production-run))
(apply #'depict-general-production-rhs markup-stream p))))) (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)))))))) (depict-general-production markup-stream (first general-productions) :definition))))))))
@ -910,13 +910,13 @@
(let ((parameter (first parameters)) (let ((parameter (first parameters))
(subtree (make-parameter-subtree grammar (rest parameters) general-production))) (subtree (make-parameter-subtree grammar (rest parameters) general-production)))
(if (nonterminal-argument? parameter) (if (nonterminal-argument? parameter)
(list ':argument parameter subtree) (list :argument parameter subtree)
(list ':attributes nil (cons parameter subtree))))) (list :attributes nil (cons parameter subtree)))))
((production? general-production) ((production? general-production)
(list ':rule (grammar-rule grammar (production-lhs general-production)))) (list :rule (grammar-rule grammar (production-lhs general-production))))
(t (t
(assert-true (generic-production? general-production)) (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. ; Create and return an initial parameter tree for the general-production.
@ -939,16 +939,16 @@
(lhs (general-rule-lhs general-rule)) (lhs (general-rule-lhs general-rule))
(new-lhs (general-grammar-symbol-substitute attribute argument lhs))) (new-lhs (general-grammar-symbol-substitute attribute argument lhs)))
(assert-true (generic-rule? general-rule)) (assert-true (generic-rule? general-rule))
(list ':rule (list :rule
(if (generic-nonterminal? new-lhs) (if (generic-nonterminal? new-lhs)
(generic-rule-substitute grammar attribute argument general-rule) (generic-rule-substitute grammar attribute argument general-rule)
(grammar-rule grammar new-lhs))))) (grammar-rule grammar new-lhs)))))
(:argument (:argument
(list ':argument (list :argument
(second subtree) (second subtree)
(substitute-argument-with attribute (third subtree)))) (substitute-argument-with attribute (third subtree))))
(:attributes (:attributes
(list ':attributes (list :attributes
(second subtree) (second subtree)
(mapcar #'(lambda (argument-subtree-binding) (mapcar #'(lambda (argument-subtree-binding)
(cons (car argument-subtree-binding) (cons (car argument-subtree-binding)
@ -958,7 +958,7 @@
(create-attribute-subtree-binding (attribute) (create-attribute-subtree-binding (attribute)
(cons attribute (substitute-argument-with attribute argument-subtree)))) (cons attribute (substitute-argument-with attribute argument-subtree))))
(setf (first parameter-subtree) ':attributes) (setf (first parameter-subtree) :attributes)
(setf (cddr parameter-subtree) (setf (cddr parameter-subtree)
(mapcar #'create-attribute-subtree-binding (mapcar #'create-attribute-subtree-binding
(grammar-parametrization-lookup-argument grammar argument)))))) (grammar-parametrization-lookup-argument grammar argument))))))
@ -1234,12 +1234,12 @@
(pos 0)) (pos 0))
(dolist (component-source production-rhs-source) (dolist (component-source production-rhs-source)
(cond (cond
((and (consp component-source) (eq (first component-source) ':-)) ((and (consp component-source) (eq (first component-source) :-))
(let ((lookaheads (rest component-source))) (let ((lookaheads (rest component-source)))
(push (push
(make-lookahead-constraint pos (assert-non-null lookaheads) lookaheads) (make-lookahead-constraint pos (assert-non-null lookaheads) lookaheads)
constraints))) constraints)))
((and (consp component-source) (eq (first component-source) ':--)) ((and (consp component-source) (eq (first component-source) :--))
(let ((lookaheads (rest component-source))) (let ((lookaheads (rest component-source)))
(push (push
(make-lookahead-constraint pos (assert-non-null (rest lookaheads)) (assert-non-null (first lookaheads))) (make-lookahead-constraint pos (assert-non-null (rest lookaheads)) (assert-non-null (first lookaheads)))
@ -1574,7 +1574,7 @@
; Emit markup paragraphs for the grammar. ; Emit markup paragraphs for the grammar.
(defun depict-grammar (markup-stream 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 markup-stream "Start nonterminal: ")
(depict-general-nonterminal markup-stream (gramar-user-start-symbol grammar) :reference)) (depict-general-nonterminal markup-stream (gramar-user-start-symbol grammar) :reference))
(dolist (nonterminal (grammar-nonterminals-list grammar)) (dolist (nonterminal (grammar-nonterminals-list grammar))

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

@ -90,25 +90,25 @@
(defun depict-terminal (markup-stream terminal &optional subscript) (defun depict-terminal (markup-stream terminal &optional subscript)
(cond (cond
((characterp terminal) ((characterp terminal)
(depict-char-style (markup-stream ':character-literal) (depict-char-style (markup-stream :character-literal)
(depict-character markup-stream terminal) (depict-character markup-stream terminal)
(when subscript (when subscript
(depict-char-style (markup-stream ':plain-subscript) (depict-char-style (markup-stream :plain-subscript)
(depict-integer markup-stream subscript))))) (depict-integer markup-stream subscript)))))
((and terminal (symbolp terminal)) ((and terminal (symbolp terminal))
(let ((name (symbol-name terminal))) (let ((name (symbol-name terminal)))
(if (and (> (length name) 0) (char= (char name 0) #\$)) (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)) (depict markup-stream (subseq (symbol-upper-mixed-case-name terminal) 1))
(when subscript (when subscript
(depict-char-style (markup-stream ':plain-subscript) (depict-char-style (markup-stream :plain-subscript)
(depict-integer markup-stream subscript)))) (depict-integer markup-stream subscript))))
(progn (progn
(depict-char-style (markup-stream ':terminal-keyword) (depict-char-style (markup-stream :terminal-keyword)
(depict markup-stream (string-downcase name))) (depict markup-stream (string-downcase name)))
(when subscript (when subscript
(depict-char-style (markup-stream ':terminal) (depict-char-style (markup-stream :terminal)
(depict-char-style (markup-stream ':plain-subscript) (depict-char-style (markup-stream :plain-subscript)
(depict-integer markup-stream subscript)))))))) (depict-integer markup-stream subscript))))))))
(t (error "Don't know how to emit markup for terminal ~S" terminal)))) (t (error "Don't know how to emit markup for terminal ~S" terminal))))
@ -131,8 +131,8 @@
(defun depict-nonterminal-attribute (markup-stream attribute) (defun depict-nonterminal-attribute (markup-stream attribute)
(depict-char-style (markup-stream ':nonterminal) (depict-char-style (markup-stream :nonterminal)
(depict-char-style (markup-stream ':nonterminal-attribute) (depict-char-style (markup-stream :nonterminal-attribute)
(depict markup-stream (symbol-lower-mixed-case-name 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)) :xi :omicron :pi :rho :sigma :tau :upsilon :phi :chi :psi :omega))
(defun depict-nonterminal-argument-symbol (markup-stream argument) (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))) (let ((argument (symbol-abbreviation argument)))
(depict markup-stream (depict markup-stream
(if (member argument *special-nonterminal-arguments*) (if (member argument *special-nonterminal-arguments*)
@ -156,7 +156,7 @@
(symbol-upper-mixed-case-name argument)))))) (symbol-upper-mixed-case-name argument))))))
(defun depict-nonterminal-argument (markup-stream 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))) (depict-nonterminal-argument-symbol markup-stream argument)))
@ -287,18 +287,18 @@
(depict-nonterminal-parameter (markup-stream parameter) (depict-nonterminal-parameter (markup-stream parameter)
(if (nonterminal-attribute? 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 markup-stream (symbol-lower-mixed-case-name parameter)))
(depict-nonterminal-argument-symbol markup-stream parameter))) (depict-nonterminal-argument-symbol markup-stream parameter)))
(depict-parametrized-nonterminal (markup-stream symbol parameters) (depict-parametrized-nonterminal (markup-stream symbol parameters)
(depict-nonterminal-name markup-stream symbol) (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 (depict-list markup-stream #'depict-nonterminal-parameter parameters
:separator ","))) :separator ",")))
(depict-general (markup-stream) (depict-general (markup-stream)
(depict-char-style (markup-stream ':nonterminal) (depict-char-style (markup-stream :nonterminal)
(cond (cond
((keywordp general-nonterminal) ((keywordp general-nonterminal)
(depict-nonterminal-name markup-stream general-nonterminal)) (depict-nonterminal-name markup-stream general-nonterminal))
@ -312,7 +312,7 @@
(generic-nonterminal-parameters general-nonterminal))) (generic-nonterminal-parameters general-nonterminal)))
(t (error "Bad nonterminal ~S" general-nonterminal))) (t (error "Bad nonterminal ~S" general-nonterminal)))
(when subscript (when subscript
(depict-char-style (markup-stream ':plain-subscript) (depict-char-style (markup-stream :plain-subscript)
(depict-integer markup-stream subscript)))))) (depict-integer markup-stream subscript))))))
(if (or (eq link :definition) (if (or (eq link :definition)

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

@ -341,7 +341,7 @@
(if (consp html-source) (if (consp html-source)
(let ((tag (first html-source)) (let ((tag (first html-source))
(contents (rest 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)) (unnest-html-source (unnest-tags (rest tag) contents))
(cons tag (mapcar #'unnest-html-source contents)))) (cons tag (mapcar #'unnest-html-source contents))))
html-source))) html-source)))
@ -397,19 +397,23 @@
;Symbols (-10 suffix means 10-point, etc.) ;Symbols (-10 suffix means 10-point, etc.)
((:bullet 1) (:script "document.write(U_bull)")) ;#x2022 ((:bullet 1) (:script "document.write(U_bull)")) ;#x2022
((:minus 1) "-")
((:not-equal 1) (:script "document.write(U_ne)")) ;#x2260 ((:not-equal 1) (:script "document.write(U_ne)")) ;#x2260
((:less-or-equal 1) (:script "document.write(U_le)")) ;#x2264 ((:less-or-equal 1) (:script "document.write(U_le)")) ;#x2264
((:greater-or-equal 1) (:script "document.write(U_ge)")) ;#x2265 ((:greater-or-equal 1) (:script "document.write(U_ge)")) ;#x2265
((:infinity 1) (:script "document.write(U_infin)")) ;#x221E ((:infinity 1) (:script "document.write(U_infin)")) ;#x221E
((:minus 1) #x2013)
((:m-dash 2) #x2014)
((:left-single-quote 1) #x2018) ((:left-single-quote 1) #x2018)
((:right-single-quote 1) #x2019) ((:right-single-quote 1) #x2019)
((:apostrophe 1) #x2019)
((:left-double-quote 1) #x201C) ((:left-double-quote 1) #x201C)
((:right-double-quote 1) #x201D) ((:right-double-quote 1) #x201D)
((:left-angle-quote 1) #x00AB) ((:left-angle-quote 1) #x00AB)
((:right-angle-quote 1) #x00BB) ((: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 ((: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 ((:up-arrow-10 1) (:script "document.write(U_uarr)")) ;#x2191
((:function-arrow-10 2) (:script "document.write(U_rarr)")) ;#x2192 ((:function-arrow-10 2) (:script "document.write(U_rarr)")) ;#x2192
((:cartesian-product-10 2) (:script "document.write(U_times)")) ;#x00D7 ((:cartesian-product-10 2) (:script "document.write(U_times)")) ;#x00D7
@ -420,9 +424,14 @@
((:union-10 1) (:script "document.write(U_cup)")) ;#x222A ((:union-10 1) (:script "document.write(U_cup)")) ;#x222A
((:member-10 2) (:script "document.write(U_isin)")) ;#x2208 ((:member-10 2) (:script "document.write(U_isin)")) ;#x2208
((:not-member-10 2) (:script "document.write(U_notin)")) ;#x2209 ((: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 ((:derives-10 2) (:script "document.write(U_rArr)")) ;#x21D2
((:left-triangle-bracket-10 1) (:script "document.write(U_lang)")) ;#x2329 ((: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-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)")) ((:alpha 1) (:script "document.write(U_alpha)"))
((:beta 1) (:script "document.write(U_beta)")) ((:beta 1) (:script "document.write(U_beta)"))
@ -480,6 +489,7 @@
(:type-expression (span (class "type-expression"))) (:type-expression (span (class "type-expression")))
(:type-name (span (class "type-name"))) (:type-name (span (class "type-name")))
(:field-name (span (class "field-name"))) (:field-name (span (class "field-name")))
(:tag-name (span (class "tag-name")))
(:global-variable (span (class "global-variable"))) (:global-variable (span (class "global-variable")))
(:local-variable (span (class "local-variable"))) (:local-variable (span (class "local-variable")))
(:action-name (span (class "action-name"))) (:action-name (span (class "action-name")))
@ -504,6 +514,8 @@
((:vector-append 2) :circle-plus-10) ((:vector-append 2) :circle-plus-10)
((:tuple-begin 1) (b :left-triangle-bracket-10)) ((:tuple-begin 1) (b :left-triangle-bracket-10))
((:tuple-end 1) (b :right-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")) ((:true 4) (:global-variable "true"))
((:false 5) (:global-variable "false")) ((:false 5) (:global-variable "false"))
((:unique 6) (:semantic-keyword "unique")) ((:unique 6) (:semantic-keyword "unique"))

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

@ -58,22 +58,37 @@
($digit-value integer digit-value digit-char-36))) ($digit-value integer digit-value digit-char-36)))
(rule :$next-input-element (rule :$next-input-element
((input-element input-element)) ((lex input-element))
(production :$next-input-element ($unit (:next-input-element unit)) $next-input-element-unit (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 (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 (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: " (%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 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 " (: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.") (: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") (%section "Unicode Character Classes")
(%charclass :unicode-character) (%charclass :unicode-character)
@ -133,74 +148,59 @@
(grammar-argument :nu_2 re div) (grammar-argument :nu_2 re div)
(rule (:next-input-element :nu) (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 (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 (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 (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 (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 (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) (%print-actions)
(rule (:input-element :nu_2) (rule (:input-element :nu_2)
((input-element input-element)) ((lex input-element))
(production (:input-element :nu_2) (:line-breaks) input-element-line-breaks (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 (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 (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 (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 (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 (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 (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 (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 ($end) end-of-input-end)
(production :end-of-input (:line-comment $end) end-of-input-line-comment) (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) (%print-actions)
(%section "Keywords and identifiers") (%section "Keywords and identifiers")
(rule :identifier-name (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 (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))) (contains-escapes (contains-escapes :initial-identifier-character-or-escape)))
(production :identifier-name (:null-escapes :initial-identifier-character-or-escape) identifier-name-initial-null-escapes (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)) (contains-escapes true))
(production :identifier-name (:identifier-name :continuing-identifier-character-or-escape) identifier-name-continuing (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 (or (contains-escapes :identifier-name)
(contains-escapes :continuing-identifier-character-or-escape)))) (contains-escapes :continuing-identifier-character-or-escape))))
(production :identifier-name (:identifier-name :null-escape) identifier-name-null-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))) (contains-escapes true)))
(production :null-escapes (:null-escape) null-escapes-one) (production :null-escapes (:null-escape) null-escapes-one)
@ -209,34 +209,34 @@
(production :null-escape (#\\ #\_) null-escape-underscore) (production :null-escape (#\\ #\_) null-escape-underscore)
(rule :initial-identifier-character-or-escape (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 (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)) (contains-escapes false))
(production :initial-identifier-character-or-escape (#\\ :hex-escape) initial-identifier-character-or-escape-escape (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)) (lex-char (begin (if (is-initial-identifier-character (lex-char :hex-escape))
(character-value :hex-escape) (return (lex-char :hex-escape))
(throw (oneof syntax-error)))) (throw syntax-error))))
(contains-escapes true))) (contains-escapes true)))
(%charclass :initial-identifier-character) (%charclass :initial-identifier-character)
(rule :continuing-identifier-character-or-escape (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 (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)) (contains-escapes false))
(production :continuing-identifier-character-or-escape (#\\ :hex-escape) continuing-identifier-character-or-escape-escape (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)) (lex-char (begin (if (is-continuing-identifier-character (lex-char :hex-escape))
(character-value :hex-escape) (return (lex-char :hex-escape))
(throw (oneof syntax-error)))) (throw syntax-error))))
(contains-escapes true))) (contains-escapes true)))
(%charclass :continuing-identifier-character) (%charclass :continuing-identifier-character)
(%print-actions) (%print-actions)
(define reserved-words (vector string) (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" "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" "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")) "switch" "synchronized" "this" "throw" "throws" "transient" "true" "try" "typeof" "use" "var" "volatile" "while" "with"))
@ -246,165 +246,159 @@
(append reserved-words non-reserved-words)) (append reserved-words non-reserved-words))
(define (member (id string) (list (vector string))) boolean (define (member (id string) (list (vector string))) boolean
(if (empty list) (rwhen (empty list)
false (return false))
(if (string= id (nth list 0)) (rwhen (= id (nth list 0) string)
true (return true))
(member id (subseq list 1))))) (return (member id (subseq list 1))))
(rule :identifier-or-keyword (rule :identifier-or-keyword
((input-element input-element)) ((lex input-element))
(production :identifier-or-keyword (:identifier-name) identifier-or-keyword-identifier-name (production :identifier-or-keyword (:identifier-name) identifier-or-keyword-identifier-name
(input-element (let ((id string (name :identifier-name))) (lex (begin
(if (and (member id keywords) (not (contains-escapes :identifier-name))) (const id string (lex-name :identifier-name))
(oneof keyword id) (if (and (member id keywords) (not (contains-escapes :identifier-name)))
(oneof identifier id)))))) (return (tag keyword id))
(return (tag identifier id)))))))
(%print-actions) (%print-actions)
(%section "Punctuators") (%section "Punctuators")
(rule :punctuator ((punctuator string)) (rule :punctuator ((lex token))
(production :punctuator (#\!) punctuator-not (punctuator "!")) (production :punctuator (#\!) punctuator-not (lex (tag punctuator "!")))
(production :punctuator (#\! #\=) punctuator-not-equal (punctuator "!=")) (production :punctuator (#\! #\=) punctuator-not-equal (lex (tag punctuator "!=")))
(production :punctuator (#\! #\= #\=) punctuator-not-identical (punctuator "!==")) (production :punctuator (#\! #\= #\=) punctuator-not-identical (lex (tag punctuator "!==")))
(production :punctuator (#\#) punctuator-hash (punctuator "#")) (production :punctuator (#\#) punctuator-hash (lex (tag punctuator "#")))
(production :punctuator (#\%) punctuator-modulo (punctuator "%")) (production :punctuator (#\%) punctuator-modulo (lex (tag punctuator "%")))
(production :punctuator (#\% #\=) punctuator-modulo-equals (punctuator "%=")) (production :punctuator (#\% #\=) punctuator-modulo-equals (lex (tag punctuator "%=")))
(production :punctuator (#\&) punctuator-and (punctuator "&")) (production :punctuator (#\&) punctuator-and (lex (tag punctuator "&")))
(production :punctuator (#\& #\&) punctuator-logical-and (punctuator "&&")) (production :punctuator (#\& #\&) punctuator-logical-and (lex (tag punctuator "&&")))
(production :punctuator (#\& #\& #\=) punctuator-logical-and-equals (punctuator "&&=")) (production :punctuator (#\& #\& #\=) punctuator-logical-and-equals (lex (tag punctuator "&&=")))
(production :punctuator (#\& #\=) punctuator-and-equals (punctuator "&=")) (production :punctuator (#\& #\=) punctuator-and-equals (lex (tag punctuator "&=")))
(production :punctuator (#\() punctuator-open-parenthesis (punctuator "(")) (production :punctuator (#\() punctuator-open-parenthesis (lex (tag punctuator "(")))
(production :punctuator (#\)) punctuator-close-parenthesis (punctuator ")")) (production :punctuator (#\)) punctuator-close-parenthesis (lex (tag punctuator ")")))
(production :punctuator (#\*) punctuator-times (punctuator "*")) (production :punctuator (#\*) punctuator-times (lex (tag punctuator "*")))
(production :punctuator (#\* #\=) punctuator-times-equals (punctuator "*=")) (production :punctuator (#\* #\=) punctuator-times-equals (lex (tag punctuator "*=")))
(production :punctuator (#\+) punctuator-plus (punctuator "+")) (production :punctuator (#\+) punctuator-plus (lex (tag punctuator "+")))
(production :punctuator (#\+ #\+) punctuator-increment (punctuator "++")) (production :punctuator (#\+ #\+) punctuator-increment (lex (tag punctuator "++")))
(production :punctuator (#\+ #\=) punctuator-plus-equals (punctuator "+=")) (production :punctuator (#\+ #\=) punctuator-plus-equals (lex (tag punctuator "+=")))
(production :punctuator (#\,) punctuator-comma (punctuator ",")) (production :punctuator (#\,) punctuator-comma (lex (tag punctuator ",")))
(production :punctuator (#\-) punctuator-minus (punctuator "-")) (production :punctuator (#\-) punctuator-minus (lex (tag punctuator "-")))
(production :punctuator (#\- #\-) punctuator-decrement (punctuator "--")) (production :punctuator (#\- #\-) punctuator-decrement (lex (tag punctuator "--")))
(production :punctuator (#\- #\=) punctuator-minus-equals (punctuator "-=")) (production :punctuator (#\- #\=) punctuator-minus-equals (lex (tag punctuator "-=")))
(production :punctuator (#\- #\>) punctuator-arrow (punctuator "->")) (production :punctuator (#\- #\>) punctuator-arrow (lex (tag punctuator "->")))
(production :punctuator (#\.) punctuator-dot (punctuator ".")) (production :punctuator (#\.) punctuator-dot (lex (tag punctuator ".")))
(production :punctuator (#\. #\.) punctuator-double-dot (punctuator "..")) (production :punctuator (#\. #\.) punctuator-double-dot (lex (tag punctuator "..")))
(production :punctuator (#\. #\. #\.) punctuator-triple-dot (punctuator "...")) (production :punctuator (#\. #\. #\.) punctuator-triple-dot (lex (tag punctuator "...")))
(production :punctuator (#\:) punctuator-colon (punctuator ":")) (production :punctuator (#\:) punctuator-colon (lex (tag punctuator ":")))
(production :punctuator (#\: #\:) punctuator-namespace (punctuator "::")) (production :punctuator (#\: #\:) punctuator-namespace (lex (tag punctuator "::")))
(production :punctuator (#\;) punctuator-semicolon (punctuator ";")) (production :punctuator (#\;) punctuator-semicolon (lex (tag punctuator ";")))
(production :punctuator (#\<) punctuator-less-than (punctuator "<")) (production :punctuator (#\<) punctuator-less-than (lex (tag punctuator "<")))
(production :punctuator (#\< #\<) punctuator-left-shift (punctuator "<<")) (production :punctuator (#\< #\<) punctuator-left-shift (lex (tag punctuator "<<")))
(production :punctuator (#\< #\< #\=) punctuator-left-shift-equals (punctuator "<<=")) (production :punctuator (#\< #\< #\=) punctuator-left-shift-equals (lex (tag punctuator "<<=")))
(production :punctuator (#\< #\=) punctuator-less-than-or-equal (punctuator "<=")) (production :punctuator (#\< #\=) punctuator-less-than-or-equal (lex (tag punctuator "<=")))
(production :punctuator (#\=) punctuator-assignment (punctuator "=")) (production :punctuator (#\=) punctuator-assignment (lex (tag punctuator "=")))
(production :punctuator (#\= #\=) punctuator-equal (punctuator "==")) (production :punctuator (#\= #\=) punctuator-equal (lex (tag punctuator "==")))
(production :punctuator (#\= #\= #\=) punctuator-identical (punctuator "===")) (production :punctuator (#\= #\= #\=) punctuator-identical (lex (tag punctuator "===")))
(production :punctuator (#\>) punctuator-greater-than (punctuator ">")) (production :punctuator (#\>) punctuator-greater-than (lex (tag punctuator ">")))
(production :punctuator (#\> #\=) punctuator-greater-than-or-equal (punctuator ">=")) (production :punctuator (#\> #\=) punctuator-greater-than-or-equal (lex (tag punctuator ">=")))
(production :punctuator (#\> #\>) punctuator-right-shift (punctuator ">>")) (production :punctuator (#\> #\>) punctuator-right-shift (lex (tag punctuator ">>")))
(production :punctuator (#\> #\> #\=) punctuator-right-shift-equals (punctuator ">>=")) (production :punctuator (#\> #\> #\=) punctuator-right-shift-equals (lex (tag punctuator ">>=")))
(production :punctuator (#\> #\> #\>) punctuator-logical-right-shift (punctuator ">>>")) (production :punctuator (#\> #\> #\>) punctuator-logical-right-shift (lex (tag punctuator ">>>")))
(production :punctuator (#\> #\> #\> #\=) punctuator-logical-right-shift-equals (punctuator ">>>=")) (production :punctuator (#\> #\> #\> #\=) punctuator-logical-right-shift-equals (lex (tag punctuator ">>>=")))
(production :punctuator (#\?) punctuator-question (punctuator "?")) (production :punctuator (#\?) punctuator-question (lex (tag punctuator "?")))
(production :punctuator (#\@) punctuator-at (punctuator "@")) (production :punctuator (#\@) punctuator-at (lex (tag punctuator "@")))
(production :punctuator (#\[) punctuator-open-bracket (punctuator "[")) (production :punctuator (#\[) punctuator-open-bracket (lex (tag punctuator "[")))
(production :punctuator (#\]) punctuator-close-bracket (punctuator "]")) (production :punctuator (#\]) punctuator-close-bracket (lex (tag punctuator "]")))
(production :punctuator (#\^) punctuator-xor (punctuator "^")) (production :punctuator (#\^) punctuator-xor (lex (tag punctuator "^")))
(production :punctuator (#\^ #\=) punctuator-xor-equals (punctuator "^=")) (production :punctuator (#\^ #\=) punctuator-xor-equals (lex (tag punctuator "^=")))
(production :punctuator (#\^ #\^) punctuator-logical-xor (punctuator "^^")) (production :punctuator (#\^ #\^) punctuator-logical-xor (lex (tag punctuator "^^")))
(production :punctuator (#\^ #\^ #\=) punctuator-logical-xor-equals (punctuator "^^=")) (production :punctuator (#\^ #\^ #\=) punctuator-logical-xor-equals (lex (tag punctuator "^^=")))
(production :punctuator (#\{) punctuator-open-brace (punctuator "{")) (production :punctuator (#\{) punctuator-open-brace (lex (tag punctuator "{")))
(production :punctuator (#\|) punctuator-or (punctuator "|")) (production :punctuator (#\|) punctuator-or (lex (tag punctuator "|")))
(production :punctuator (#\| #\=) punctuator-or-equals (punctuator "|=")) (production :punctuator (#\| #\=) punctuator-or-equals (lex (tag punctuator "|=")))
(production :punctuator (#\| #\|) punctuator-logical-or (punctuator "||")) (production :punctuator (#\| #\|) punctuator-logical-or (lex (tag punctuator "||")))
(production :punctuator (#\| #\| #\=) punctuator-logical-or-equals (punctuator "||=")) (production :punctuator (#\| #\| #\=) punctuator-logical-or-equals (lex (tag punctuator "||=")))
(production :punctuator (#\}) punctuator-close-brace (punctuator "}")) (production :punctuator (#\}) punctuator-close-brace (lex (tag punctuator "}")))
(production :punctuator (#\~) punctuator-complement (punctuator "~"))) (production :punctuator (#\~) punctuator-complement (lex (tag punctuator "~"))))
(rule :division-punctuator ((punctuator string)) (rule :division-punctuator ((lex token))
(production :division-punctuator (#\/ (:- #\/ #\*)) punctuator-divide (punctuator "/")) (production :division-punctuator (#\/ (:- #\/ #\*)) punctuator-divide (lex (tag punctuator "/")))
(production :division-punctuator (#\/ #\=) punctuator-divide-equals (punctuator "/="))) (production :division-punctuator (#\/ #\=) punctuator-divide-equals (lex (tag punctuator "/="))))
(%print-actions) (%print-actions)
(%section "Numeric literals") (%section "Numeric literals")
(rule :numeric-literal ((float64-value float64)) (rule :numeric-literal ((lex token))
(production :numeric-literal (:decimal-literal) numeric-literal-decimal (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 (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) (%print-actions)
(define (expt (base rational) (exponent integer)) rational (rule :decimal-literal ((lex-number 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))
(production :decimal-literal (:mantissa) decimal-literal (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 (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) (%charclass :letter-e)
(rule :mantissa ((rational-value rational)) (rule :mantissa ((lex-number rational))
(production :mantissa (:decimal-integer-literal) mantissa-integer (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 (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 (production :mantissa (:decimal-integer-literal #\. :fraction) mantissa-integer-dot-fraction
(rational-value (rational+ (integer-value :decimal-integer-literal) (lex-number (rat+ (lex-number :decimal-integer-literal)
(rational-value :fraction)))) (lex-number :fraction))))
(production :mantissa (#\. :fraction) mantissa-dot-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 (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 (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 (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 (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) (%charclass :non-zero-digit)
(rule :fraction ((rational-value rational)) (rule :fraction ((lex-number rational))
(production :fraction (:decimal-digits) fraction-decimal-digits (production :fraction (:decimal-digits) fraction-decimal-digits
(rational-value (rational/ (integer-value :decimal-digits) (lex-number (rat/ (lex-number :decimal-digits)
(expt 10 (n-digits :decimal-digits)))))) (expt 10 (n-digits :decimal-digits))))))
(%print-actions) (%print-actions)
(rule :signed-integer ((integer-value integer)) (rule :signed-integer ((lex-number integer))
(production :signed-integer (:decimal-digits) signed-integer-no-sign (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 (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 (production :signed-integer (#\- :decimal-digits) signed-integer-minus
(integer-value (neg (integer-value :decimal-digits))))) (lex-number (neg (lex-number :decimal-digits)))))
(%print-actions) (%print-actions)
(rule :decimal-digits (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 (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)) (n-digits 1))
(production :decimal-digits (:decimal-digits :a-s-c-i-i-digit) decimal-digits-rest (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)))) (n-digits (+ (n-digits :decimal-digits) 1))))
(%print-actions) (%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 (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 (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 :letter-x)
(%charclass :hex-digit) (%charclass :hex-digit)
(%print-actions) (%print-actions)
@ -412,100 +406,100 @@
(%section "String literals") (%section "String literals")
(grammar-argument :theta single double) (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 (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 (production :string-literal (#\" (:string-chars double) #\") string-literal-double
(string-value (string-value :string-chars)))) (lex (tag string (lex-string :string-chars)))))
(%print-actions) (%print-actions)
(rule (:string-chars :theta) ((string-value string)) (rule (:string-chars :theta) ((lex-string string))
(production (:string-chars :theta) () string-chars-none (production (:string-chars :theta) () string-chars-none
(string-value "")) (lex-string ""))
(production (:string-chars :theta) ((:string-chars :theta) (:string-char :theta)) string-chars-some (production (:string-chars :theta) ((:string-chars :theta) (:string-char :theta)) string-chars-some
(string-value (append (string-value :string-chars) (lex-string (append (lex-string :string-chars)
(vector (character-value :string-char))))) (vector (lex-char :string-char)))))
(production (:string-chars :theta) ((:string-chars :theta) :null-escape) string-chars-null-escape (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 (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 (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 single))
(%charclass (:literal-string-char double)) (%charclass (:literal-string-char double))
(%print-actions) (%print-actions)
(rule :string-escape ((character-value character)) (rule :string-escape ((lex-char character))
(production :string-escape (:control-escape) string-escape-control (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 (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 (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 (production :string-escape (:identity-escape) string-escape-non-escape
(character-value ($default-action :identity-escape)))) (lex-char ($default-action :identity-escape))))
(%charclass :identity-escape) (%charclass :identity-escape)
(%print-actions) (%print-actions)
(rule :control-escape ((character-value character)) (rule :control-escape ((lex-char character))
(production :control-escape (#\b) control-escape-backspace (character-value #?0008)) (production :control-escape (#\b) control-escape-backspace (lex-char #?0008))
(production :control-escape (#\f) control-escape-form-feed (character-value #?000C)) (production :control-escape (#\f) control-escape-form-feed (lex-char #?000C))
(production :control-escape (#\n) control-escape-new-line (character-value #?000A)) (production :control-escape (#\n) control-escape-new-line (lex-char #?000A))
(production :control-escape (#\r) control-escape-return (character-value #?000D)) (production :control-escape (#\r) control-escape-return (lex-char #?000D))
(production :control-escape (#\t) control-escape-tab (character-value #?0009)) (production :control-escape (#\t) control-escape-tab (lex-char #?0009))
(production :control-escape (#\v) control-escape-vertical-tab (character-value #?000B))) (production :control-escape (#\v) control-escape-vertical-tab (lex-char #?000B)))
(%print-actions) (%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 (production :zero-escape (#\0 (:- :a-s-c-i-i-digit)) zero-escape-zero
(character-value #?0000))) (lex-char #?0000)))
(%print-actions) (%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 (production :hex-escape (#\x :hex-digit :hex-digit) hex-escape-2
(character-value (code-to-character (+ (* 16 (hex-value :hex-digit 1)) (lex-char (code-to-character (+ (* 16 (hex-value :hex-digit 1))
(hex-value :hex-digit 2))))) (hex-value :hex-digit 2)))))
(production :hex-escape (#\u :hex-digit :hex-digit :hex-digit :hex-digit) hex-escape-4 (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)) (lex-char (code-to-character (+ (+ (+ (* 4096 (hex-value :hex-digit 1))
(* 256 (hex-value :hex-digit 2))) (* 256 (hex-value :hex-digit 2)))
(* 16 (hex-value :hex-digit 3))) (* 16 (hex-value :hex-digit 3)))
(hex-value :hex-digit 4)))))) (hex-value :hex-digit 4))))))
(%print-actions) (%print-actions)
(%section "Regular expression literals") (%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 (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 (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 (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 (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 (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 (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 (production :reg-exp-chars (:reg-exp-chars :reg-exp-char) reg-exp-chars-more
(r-e-body (append (r-e-body :reg-exp-chars) (lex-string (append (lex-string :reg-exp-chars)
(r-e-body :reg-exp-char))))) (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 (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 (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) (%charclass :ordinary-reg-exp-char)
))) )))
@ -521,41 +515,39 @@
"JS20/LexerCharClasses.rtf" "JS20/LexerCharClasses.rtf"
"JavaScript 2 Lexical Character Classes" "JavaScript 2 Lexical Character Classes"
#'(lambda (rtf-stream) #'(lambda (rtf-stream)
(depict-paragraph (rtf-stream ':grammar-header) (depict-paragraph (rtf-stream :grammar-header)
(depict rtf-stream "Character Classes")) (depict rtf-stream "Character Classes"))
(dolist (charclass (lexer-charclasses *ll*)) (dolist (charclass (lexer-charclasses *ll*))
(depict-charclass rtf-stream charclass)) (depict-charclass rtf-stream charclass))
(depict-paragraph (rtf-stream ':grammar-header) (depict-paragraph (rtf-stream :grammar-header)
(depict rtf-stream "Grammar")) (depict rtf-stream "Grammar"))
(depict-grammar rtf-stream *lg*))) (depict-grammar rtf-stream *lg*)))
(values (values
(depict-rtf-to-local-file (depict-rtf-to-local-file
"JS20/LexerGrammar.rtf" "JS20/LexerGrammar.rtf"
"JavaScript 2 Lexical Grammar" "JavaScript 2 Lexical Grammar"
#'(lambda (rtf-stream) #'(lambda (rtf-stream)
(depict-world-commands rtf-stream *lw* :visible-semantics nil))) (depict-world-commands rtf-stream *lw* :visible-semantics nil)))
(depict-rtf-to-local-file (depict-rtf-to-local-file
"JS20/LexerSemantics.rtf" "JS20/LexerSemantics.rtf"
"JavaScript 2 Lexical Semantics" "JavaScript 2 Lexical Semantics"
#'(lambda (rtf-stream) #'(lambda (rtf-stream)
(depict-world-commands rtf-stream *lw*)))) (depict-world-commands rtf-stream *lw*)))
(depict-html-to-local-file
(values "JS20/LexerGrammar.html"
(depict-html-to-local-file "JavaScript 2 Lexical Grammar"
"JS20/LexerGrammar.html" t
"JavaScript 2 Lexical Grammar" #'(lambda (rtf-stream)
t (depict-world-commands rtf-stream *lw* :visible-semantics nil))
#'(lambda (rtf-stream) :external-link-base "notation.html")
(depict-world-commands rtf-stream *lw* :visible-semantics nil)) (depict-html-to-local-file
:external-link-base "notation.html") "JS20/LexerSemantics.html"
(depict-html-to-local-file "JavaScript 2 Lexical Semantics"
"JS20/LexerSemantics.html" t
"JavaScript 2 Lexical Semantics" #'(lambda (rtf-stream)
t (depict-world-commands rtf-stream *lw*))
#'(lambda (rtf-stream) :external-link-base "notation.html"))
(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)) (with-local-output (s "JS20/LexerGrammar.txt") (print-lexer *ll* s) (print-grammar *lg* s))

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

Разница между файлами не показана из-за своего большого размера Загрузить разницу

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

@ -41,7 +41,8 @@
(($default-action character nil identity) (($default-action character nil identity)
($digit-value integer digit-value digit-char-36))) ($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") (%section "Unicode Character Classes")
(%charclass :unicode-character) (%charclass :unicode-character)
@ -56,34 +57,38 @@
(%section "Regular Expression Definitions") (%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 (%text :semantics
"Field " (:field str r-e-input) " is the input string. " "Field " (:label re-input str) " is the input string. "
(:field ignore-case r-e-input) ", " (:label re-input ignore-case) ", "
(:field multiline r-e-input) ", and " (:label re-input multiline) ", and "
(:field span r-e-input) " are the corresponding regular expression flags.") (:label re-input span) " are the corresponding regular expression flags.")
(deftype r-e-result (oneof (success r-e-match) failure)) (deftag present (s string))
(deftype r-e-match (tuple (end-index integer) (deftag absent)
(captures (vector capture)))) (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 (%text :semantics
"A " (:type r-e-match) " holds an intermediate state during the pattern-matching process. " "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. " " 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. " " 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.") " 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)) (deftype continuation (-> (r-e-match) r-e-result))
(%text :semantics (%text :semantics
"A " (:type continuation) "A " (:type continuation)
" is a function that attempts to match the remaining portion of the pattern against the input string, " " 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. " "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 " "If a match is possible, it returns a " (:tag re-match)
(:type r-e-match) " state; if no match is possible, it returns a " (:field failure r-e-result) " result.") " 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)) (deftype matcher (-> (r-e-input r-e-match continuation) r-e-result))
(%text :semantics (%text :semantics
@ -92,37 +97,37 @@
"starting at the intermediate state given by its " (:type r-e-match) " argument. " "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 " "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. " "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.") "trying various alternatives at pattern choice points.")
(%text :semantics (%text :semantics
"The " (:type r-e-input) " parameter contains the input string and is merely passed down to subroutines.") "The " (:type r-e-input) " parameter contains the input string and is merely passed down to subroutines.")
(deftype matcher-generator (-> (integer) matcher))
(%text :semantics (%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 " " 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 " "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.") "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? (define (character-set-matcher (acceptance-set (set character)) (invert boolean)) matcher ;*********ignore case?
(function ((t r-e-input) (x r-e-match) (c continuation)) (function (m (t r-e-input) (x r-e-match) (c continuation)) r-e-result
(let ((i integer (& end-index x)) (const i integer (& end-index x))
(s string (& str t))) (const s string (& str t))
(if (= i (length s)) (cond
(oneof failure) ((= i (length s)) (return failure))
(if (xor (character-set-member (nth s i) acceptance-set) invert) ((xor (character-set-member (nth s i) acceptance-set) invert)
(c (tuple r-e-match (+ i 1) (& captures x))) (return (c (tag re-match (+ i 1) (& captures x)))))
(oneof failure)))))) (nil (return failure))))
(return m))
(%text :semantics (%text :semantics
(:global character-set-matcher) " returns a " (:type matcher) (:global character-set-matcher) " returns a " (:type matcher)
" that matches a single input string character. If " " 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 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).") (:local acceptance-set) " set of characters (possibly ignoring case).")
(define (character-matcher (ch character)) matcher (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 (%text :semantics
(:global character-matcher) " returns a " (:type matcher) (:global character-matcher) " returns a " (:type matcher)
" that matches a single input string character. The match succeeds if the character is the same as " " 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") (%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 (production :regular-expression-pattern (:disjunction) regular-expression-pattern-disjunction
(exec (execute
(let ((match matcher ((gen-matcher :disjunction) 0))) (begin
(function ((t r-e-input) (index integer)) (const m1 matcher ((gen-matcher :disjunction) 0))
(match (function (e (t r-e-input) (index integer)) r-e-result
t (const x r-e-match (tag re-match index (fill-capture (count-parens :disjunction))))
(tuple r-e-match index (fill-capture (count-parens :disjunction))) (return (m1 t x success-continuation)))
success-continuation)))))) (return e)))))
(%print-actions) (%print-actions)
(define (success-continuation (x r-e-match)) r-e-result (define (success-continuation (x r-e-match)) r-e-result
(oneof success x)) (return x))
(define (fill-capture (i integer)) (vector capture) (define (fill-capture (i integer)) (vector capture)
(if (= i 0) (if (= i 0)
(vector-of capture) (return (vector-of capture))
(append (fill-capture (- i 1)) (vector (oneof absent))))) (return (append (fill-capture (- i 1)) (vector-of capture absent)))))
(%subsection "Disjunctions") (%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 (production :disjunction (:alternative) disjunction-one
(gen-matcher (gen-matcher :alternative)) (gen-matcher (gen-matcher :alternative))
(count-parens (count-parens :alternative))) (count-parens (count-parens :alternative)))
(production :disjunction (:alternative #\| :disjunction) disjunction-more (production :disjunction (:alternative #\| :disjunction) disjunction-more
((gen-matcher (paren-index integer)) ((gen-matcher paren-index)
(let ((match1 matcher ((gen-matcher :alternative) paren-index)) (const m1 matcher ((gen-matcher :alternative) paren-index))
(match2 matcher ((gen-matcher :disjunction) (+ paren-index (count-parens :alternative))))) (const m2 matcher ((gen-matcher :disjunction) (+ paren-index (count-parens :alternative))))
(function ((t r-e-input) (x r-e-match) (c continuation)) (function (m3 (t r-e-input) (x r-e-match) (c continuation)) r-e-result
(case (match1 t x c) (const y r-e-result (m1 t x c))
((success y r-e-match) (oneof success y)) (case y
(failure (match2 t x c)))))) (:select r-e-match (return y))
(:select (tag failure) (return (m2 t x c)))))
(return m3))
(count-parens (+ (count-parens :alternative) (count-parens :disjunction))))) (count-parens (+ (count-parens :alternative) (count-parens :disjunction)))))
(%print-actions) (%print-actions)
@ -173,20 +180,22 @@
(%subsection "Alternatives") (%subsection "Alternatives")
(rule :alternative ((gen-matcher matcher-generator) (count-parens integer)) (rule :alternative ((gen-matcher (-> (integer) matcher)) (count-parens integer))
(production :alternative () alternative-none (production :alternative () alternative-none
((gen-matcher (paren-index integer :unused)) ((gen-matcher (paren-index :unused))
(function ((t r-e-input :unused) (x r-e-match) (c continuation)) (function (m (t r-e-input :unused) (x r-e-match) (c continuation)) r-e-result
(c x))) (return (c x)))
(return m))
(count-parens 0)) (count-parens 0))
(production :alternative (:alternative :term) alternative-some (production :alternative (:alternative :term) alternative-some
((gen-matcher (paren-index integer)) ((gen-matcher paren-index)
(let ((match1 matcher ((gen-matcher :alternative) paren-index)) (const m1 matcher ((gen-matcher :alternative) paren-index))
(match2 matcher ((gen-matcher :term) (+ paren-index (count-parens :alternative))))) (const m2 matcher ((gen-matcher :term) (+ paren-index (count-parens :alternative))))
(function ((t r-e-input) (x r-e-match) (c continuation)) (function (m3 (t r-e-input) (x r-e-match) (c continuation)) r-e-result
(let ((d continuation (function ((y r-e-match)) (function (d (y r-e-match)) r-e-result
(match2 t y c)))) (return (m2 t y c)))
(match1 t x d))))) (return (m1 t x d)))
(return m3))
(count-parens (+ (count-parens :alternative) (count-parens :term))))) (count-parens (+ (count-parens :alternative) (count-parens :term)))))
(%print-actions) (%print-actions)
@ -194,28 +203,28 @@
(%subsection "Terms") (%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 (production :term (:assertion) term-assertion
((gen-matcher (paren-index integer :unused)) ((gen-matcher (paren-index :unused))
(function ((t r-e-input) (x r-e-match) (c continuation)) (function (m (t r-e-input) (x r-e-match) (c continuation)) r-e-result
(if ((test-assertion :assertion) t x) (if ((test-assertion :assertion) t x)
(c x) (return (c x))
(oneof failure)))) (return failure)))
(return m))
(count-parens 0)) (count-parens 0))
(production :term (:atom) term-atom (production :term (:atom) term-atom
(gen-matcher (gen-matcher :atom)) (gen-matcher (gen-matcher :atom))
(count-parens (count-parens :atom))) (count-parens (count-parens :atom)))
(production :term (:atom :quantifier) term-quantified-atom (production :term (:atom :quantifier) term-quantified-atom
((gen-matcher (paren-index integer)) ((gen-matcher paren-index)
(let ((match matcher ((gen-matcher :atom) paren-index)) (const m matcher ((gen-matcher :atom) paren-index))
(min integer (minimum :quantifier)) (const min integer (minimum :quantifier))
(max limit (maximum :quantifier)) (const max limit (maximum :quantifier))
(greedy boolean (greedy :quantifier))) (const greedy boolean (greedy :quantifier))
(if (case max (when (:narrow-true (not-in (tag +infinity) max))
((finite m integer) (< m min)) (rwhen (< max min)
(infinite false)) (throw syntax-error)))
(throw (oneof syntax-error)) (return (repeat-matcher m min max greedy paren-index (count-parens :atom))))
(repeat-matcher match min max greedy paren-index (count-parens :atom)))))
(count-parens (count-parens :atom)))) (count-parens (count-parens :atom))))
(%print-actions) (%print-actions)
@ -234,22 +243,22 @@
(rule :quantifier-prefix ((minimum integer) (maximum limit)) (rule :quantifier-prefix ((minimum integer) (maximum limit))
(production :quantifier-prefix (#\*) quantifier-prefix-zero-or-more (production :quantifier-prefix (#\*) quantifier-prefix-zero-or-more
(minimum 0) (minimum 0)
(maximum (oneof infinite))) (maximum +infinity))
(production :quantifier-prefix (#\+) quantifier-prefix-one-or-more (production :quantifier-prefix (#\+) quantifier-prefix-one-or-more
(minimum 1) (minimum 1)
(maximum (oneof infinite))) (maximum +infinity))
(production :quantifier-prefix (#\?) quantifier-prefix-zero-or-one (production :quantifier-prefix (#\?) quantifier-prefix-zero-or-one
(minimum 0) (minimum 0)
(maximum (oneof finite 1))) (maximum 1))
(production :quantifier-prefix (#\{ :decimal-digits #\}) quantifier-prefix-repeat (production :quantifier-prefix (#\{ :decimal-digits #\}) quantifier-prefix-repeat
(minimum (integer-value :decimal-digits)) (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 (production :quantifier-prefix (#\{ :decimal-digits #\, #\}) quantifier-prefix-repeat-or-more
(minimum (integer-value :decimal-digits)) (minimum (integer-value :decimal-digits))
(maximum (oneof infinite))) (maximum +infinity))
(production :quantifier-prefix (#\{ :decimal-digits #\, :decimal-digits #\}) quantifier-prefix-repeat-range (production :quantifier-prefix (#\{ :decimal-digits #\, :decimal-digits #\}) quantifier-prefix-repeat-range
(minimum (integer-value :decimal-digits 1)) (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)) (rule :decimal-digits ((integer-value integer))
(production :decimal-digits (:decimal-digit) decimal-digits-first (production :decimal-digits (:decimal-digit) decimal-digits-first
@ -259,40 +268,45 @@
(%charclass :decimal-digit) (%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 (define (reset-parens (x r-e-match) (p integer) (n-parens integer)) r-e-match
(if (= n-parens 0) (var captures (vector capture) (& captures x))
x (var i integer p)
(let ((y r-e-match (tuple r-e-match (& end-index x) (while (< i (+ p n-parens))
(set-nth (& captures x) p (oneof absent))))) (<- captures (set-nth captures i absent))
(reset-parens y (+ p 1) (- n-parens 1))))) (<- 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 (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)) (function (m (t r-e-input) (x r-e-match) (c continuation)) r-e-result
(if (case max (rwhen (= max 0 limit)
((finite m integer) (= m 0)) (return (c x)))
(infinite false)) (function (d (y r-e-match)) r-e-result
(c x) (rwhen (and (= min 0) (= (& end-index y) (& end-index x)))
(let ((d continuation (function ((y r-e-match)) (return failure))
(if (and (= min 0) (var new-min integer min)
(= (& end-index y) (& end-index x))) (when (/= min 0)
(oneof failure) (<- new-min (- min 1)))
(let ((new-min integer (if (= min 0) 0 (- min 1))) (var new-max limit max)
(new-max limit (case max (when (:narrow-true (not-in (tag +infinity) max))
((finite m integer) (oneof finite (- m 1))) (<- new-max (- max 1)))
(infinite (oneof infinite))))) (const m2 matcher (repeat-matcher body new-min new-max greedy paren-index n-body-parens))
((repeat-matcher body new-min new-max greedy paren-index n-body-parens) t y c))))) (return (m2 t y c)))
(xr r-e-match (reset-parens x paren-index n-body-parens))) (const xr r-e-match (reset-parens x paren-index n-body-parens))
(if (/= min 0) (cond
(body t xr d) ((/= min 0) (return (body t xr d)))
(if greedy (greedy
(case (body t xr d) (const z r-e-result (body t xr d))
((success z r-e-match) (oneof success z)) (case z
(failure (c x))) (:select r-e-match (return z))
(case (c x) (:select (tag failure) (return (c x)))))
((success z r-e-match) (oneof success z)) (nil
(failure (body t xr d))))))))) (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) (%print-actions)
@ -301,95 +315,100 @@
(rule :assertion ((test-assertion (-> (r-e-input r-e-match) boolean))) (rule :assertion ((test-assertion (-> (r-e-input r-e-match) boolean)))
(production :assertion (#\^) assertion-beginning (production :assertion (#\^) assertion-beginning
((test-assertion (t r-e-input) (x r-e-match)) ((test-assertion t x)
(if (= (& end-index x) 0) (return (or (= (& end-index x) 0)
true (and (& multiline t)
(and (& multiline t) (character-set-member (nth (& str t) (- (& end-index x) 1)) line-terminators))))))
(character-set-member (nth (& str t) (- (& end-index x) 1)) line-terminators)))))
(production :assertion (#\$) assertion-end (production :assertion (#\$) assertion-end
((test-assertion (t r-e-input) (x r-e-match)) ((test-assertion t x)
(if (= (& end-index x) (length (& str t))) (return (or (= (& end-index x) (length (& str t)))
true (and (& multiline t)
(and (& multiline t) (character-set-member (nth (& str t) (& end-index x)) line-terminators))))))
(character-set-member (nth (& str t) (& end-index x)) line-terminators)))))
(production :assertion (#\\ #\b) assertion-word-boundary (production :assertion (#\\ #\b) assertion-word-boundary
((test-assertion (t r-e-input) (x r-e-match)) ((test-assertion t x)
(at-word-boundary (& end-index x) (& str t)))) (return (at-word-boundary (& end-index x) (& str t)))))
(production :assertion (#\\ #\B) assertion-non-word-boundary (production :assertion (#\\ #\B) assertion-non-word-boundary
((test-assertion (t r-e-input) (x r-e-match)) ((test-assertion t x)
(not (at-word-boundary (& end-index x) (& str t)))))) (return (not (at-word-boundary (& end-index x) (& str t)))))))
(%print-actions) (%print-actions)
(define (at-word-boundary (i integer) (s string)) boolean (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 (define (in-word (i integer) (s string)) boolean
(if (or (= i -1) (= i (length s))) (if (or (= i -1) (= i (length s)))
false (return false)
(character-set-member (nth s i) re-word-characters))) (return (character-set-member (nth s i) re-word-characters))))
(%section "Atoms") (%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 (production :atom (:pattern-character) atom-pattern-character
((gen-matcher (paren-index integer :unused)) ((gen-matcher (paren-index :unused))
(character-matcher ($default-action :pattern-character))) (return (character-matcher ($default-action :pattern-character))))
(count-parens 0)) (count-parens 0))
(production :atom (#\.) atom-dot (production :atom (#\.) atom-dot
((gen-matcher (paren-index integer :unused)) ((gen-matcher (paren-index :unused))
(function ((t r-e-input) (x r-e-match) (c continuation)) (function (m1 (t r-e-input) (x r-e-match) (c continuation)) r-e-result
((character-set-matcher (if (& span t) (set-of character) line-terminators) true) t x c))) (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)) (count-parens 0))
(production :atom (:null-escape) atom-null-escape (production :atom (:null-escape) atom-null-escape
((gen-matcher (paren-index integer :unused)) ((gen-matcher (paren-index :unused))
(function ((t r-e-input :unused) (x r-e-match) (c continuation)) (function (m (t r-e-input :unused) (x r-e-match) (c continuation)) r-e-result
(c x))) (return (c x)))
(return m))
(count-parens 0)) (count-parens 0))
(production :atom (#\\ :atom-escape) atom-atom-escape (production :atom (#\\ :atom-escape) atom-atom-escape
(gen-matcher (gen-matcher :atom-escape)) (gen-matcher (gen-matcher :atom-escape))
(count-parens 0)) (count-parens 0))
(production :atom (:character-class) atom-character-class (production :atom (:character-class) atom-character-class
((gen-matcher (paren-index integer :unused)) ((gen-matcher (paren-index :unused))
(let ((a (set character) (acceptance-set :character-class))) (const a (set character) (acceptance-set :character-class))
(character-set-matcher a (invert :character-class)))) (return (character-set-matcher a (invert :character-class))))
(count-parens 0)) (count-parens 0))
(production :atom (#\( :disjunction #\)) atom-parentheses (production :atom (#\( :disjunction #\)) atom-parentheses
((gen-matcher (paren-index integer)) ((gen-matcher paren-index)
(let ((match matcher ((gen-matcher :disjunction) (+ paren-index 1)))) (const m1 matcher ((gen-matcher :disjunction) (+ paren-index 1)))
(function ((t r-e-input) (x r-e-match) (c continuation)) (function (m2 (t r-e-input) (x r-e-match) (c continuation)) r-e-result
(let ((d continuation (function (d (y r-e-match)) r-e-result
(function ((y r-e-match)) (const ref capture (tag present (subseq (& str t) (& end-index x) (- (& end-index y) 1))))
(let ((updated-captures (vector capture) (const updated-captures (vector capture)
(set-nth (& captures y) paren-index (set-nth (& captures y) paren-index ref))
(oneof present (subseq (& str t) (& end-index x) (- (& end-index y) 1)))))) (return (c (tag re-match (& end-index y) updated-captures))))
(c (tuple r-e-match (& end-index y) updated-captures)))))) (return (m1 t x d)))
(match t x d))))) (return m2))
(count-parens (+ (count-parens :disjunction) 1))) (count-parens (+ (count-parens :disjunction) 1)))
(production :atom (#\( #\? #\: :disjunction #\)) atom-non-capturing-parentheses (production :atom (#\( #\? #\: :disjunction #\)) atom-non-capturing-parentheses
(gen-matcher (gen-matcher :disjunction)) (gen-matcher (gen-matcher :disjunction))
(count-parens (count-parens :disjunction))) (count-parens (count-parens :disjunction)))
(production :atom (#\( #\? #\= :disjunction #\)) atom-positive-lookahead (production :atom (#\( #\? #\= :disjunction #\)) atom-positive-lookahead
((gen-matcher (paren-index integer)) ((gen-matcher paren-index)
(let ((match matcher ((gen-matcher :disjunction) paren-index))) (const m1 matcher ((gen-matcher :disjunction) paren-index))
(function ((t r-e-input) (x r-e-match) (c continuation)) (function (m2 (t r-e-input) (x r-e-match) (c continuation)) r-e-result
;(let ((d continuation ;(function (d (y r-e-match)) r-e-result
; (function ((y r-e-match)) ; (return (c (tag re-match (& end-index x) (& captures y)))))
; (c (tuple r-e-match (& end-index x) (& captures y)))))) ;(return (m1 t x d)))))
; (match t x d))))) (const y r-e-result (m1 t x success-continuation))
(case (match t x success-continuation) (case y
((success y r-e-match) (:narrow r-e-match (return (c (tag re-match (& end-index x) (& captures y)))))
(c (tuple r-e-match (& end-index x) (& captures y)))) (:select (tag failure) (return failure))))
(failure (oneof failure)))))) (return m2))
(count-parens (count-parens :disjunction))) (count-parens (count-parens :disjunction)))
(production :atom (#\( #\? #\! :disjunction #\)) atom-negative-lookahead (production :atom (#\( #\? #\! :disjunction #\)) atom-negative-lookahead
((gen-matcher (paren-index integer)) ((gen-matcher paren-index)
(let ((match matcher ((gen-matcher :disjunction) paren-index))) (const m1 matcher ((gen-matcher :disjunction) paren-index))
(function ((t r-e-input) (x r-e-match) (c continuation)) (function (m2 (t r-e-input) (x r-e-match) (c continuation)) r-e-result
(case (match t x success-continuation) (case (m1 t x success-continuation)
((success y r-e-match :unused) (oneof failure)) (:select r-e-match (return failure))
(failure (c x)))))) (:select (tag failure) (return (c x)))))
(return m2))
(count-parens (count-parens :disjunction)))) (count-parens (count-parens :disjunction))))
(%charclass :pattern-character) (%charclass :pattern-character)
@ -400,39 +419,39 @@
(production :null-escape (#\\ #\_) null-escape-underscore) (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 (production :atom-escape (:decimal-escape) atom-escape-decimal
((gen-matcher (paren-index integer)) ((gen-matcher paren-index)
(let ((n integer (escape-value :decimal-escape))) (const n integer (escape-value :decimal-escape))
(if (= n 0) (cond
(character-matcher #?0000) ((= n 0) (return (character-matcher #?0000)))
(if (> n paren-index) ((> n paren-index) (throw syntax-error))
(throw (oneof syntax-error)) (nil (return (backreference-matcher n))))))
(backreference-matcher n))))))
(production :atom-escape (:character-escape) atom-escape-character (production :atom-escape (:character-escape) atom-escape-character
((gen-matcher (paren-index integer :unused)) ((gen-matcher (paren-index :unused))
(character-matcher (character-value :character-escape)))) (return (character-matcher (character-value :character-escape)))))
(production :atom-escape (:character-class-escape) atom-escape-character-class (production :atom-escape (:character-class-escape) atom-escape-character-class
((gen-matcher (paren-index integer :unused)) ((gen-matcher (paren-index :unused))
(character-set-matcher (acceptance-set :character-class-escape) false)))) (return (character-set-matcher (acceptance-set :character-class-escape) false)))))
(%print-actions) (%print-actions)
(define (backreference-matcher (n integer)) matcher (define (backreference-matcher (n integer)) matcher
(function ((t r-e-input) (x r-e-match) (c continuation)) (function (m (t r-e-input) (x r-e-match) (c continuation)) r-e-result
(case (nth-backreference x n) (const ref capture (nth-backreference x n))
((present ref string) (case ref
(let ((i integer (& end-index x)) (:narrow (tag present)
(s string (& str t))) (const i integer (& end-index x))
(let ((j integer (+ i (length ref)))) (const s string (& str t))
(if (> j (length s)) (const j integer (+ i (length (& s ref))))
(oneof failure) (if (and (<= j (length s))
(if (string= (subseq s i (- j 1)) ref) ;*********ignore case? (= (subseq s i (- j 1)) (& s ref) string)) ;*********ignore case?
(c (tuple r-e-match j (& captures x))) (return (c (tag re-match j (& captures x))))
(oneof failure)))))) (return failure)))
(absent (c x))))) (:select (tag absent) (return (c x)))))
(return m))
(define (nth-backreference (x r-e-match) (n integer)) capture (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)) (rule :character-escape ((character-value character))
@ -539,21 +558,20 @@
(acceptance-set :nonempty-class-ranges)))) (acceptance-set :nonempty-class-ranges))))
(production (:nonempty-class-ranges :delta) ((:class-atom :delta) #\- (:class-atom dash) :class-ranges) nonempty-class-ranges-range (production (:nonempty-class-ranges :delta) ((:class-atom :delta) #\- (:class-atom dash) :class-ranges) nonempty-class-ranges-range
(acceptance-set (acceptance-set
(let ((range (set character) (character-range (acceptance-set :class-atom 1) (character-set-union (character-range (acceptance-set :class-atom 1) (acceptance-set :class-atom 2))
(acceptance-set :class-atom 2)))) (acceptance-set :class-ranges))))
(character-set-union range (acceptance-set :class-ranges)))))
(production (:nonempty-class-ranges :delta) (:null-escape :class-ranges) nonempty-class-ranges-null-escape (production (:nonempty-class-ranges :delta) (:null-escape :class-ranges) nonempty-class-ranges-null-escape
(acceptance-set (acceptance-set :class-ranges)))) (acceptance-set (acceptance-set :class-ranges))))
(%print-actions) (%print-actions)
(define (character-range (low (set character)) (high (set character))) (set character) (define (character-range (low (set character)) (high (set character))) (set character)
(if (or (/= (character-set-length low) 1) (/= (character-set-length high) 1)) (rwhen (or (/= (character-set-length low) 1) (/= (character-set-length high) 1))
(throw (oneof syntax-error)) (throw syntax-error))
(let ((l character (character-set-min low)) (const l character (character-set-min low))
(h character (character-set-min high))) (const h character (character-set-min high))
(if (char<= l h) (if (<= l h character)
(set-of-ranges character l h) (return (set-of-ranges character l h))
(throw (oneof syntax-error)))))) (throw syntax-error)))
(%subsection "Character Class Range Atoms") (%subsection "Character Class Range Atoms")
@ -570,9 +588,10 @@
(rule :class-escape ((acceptance-set (set character))) (rule :class-escape ((acceptance-set (set character)))
(production :class-escape (:decimal-escape) class-escape-decimal (production :class-escape (:decimal-escape) class-escape-decimal
(acceptance-set (acceptance-set
(if (= (escape-value :decimal-escape) 0) (begin
(set-of character #?0000) (if (= (escape-value :decimal-escape) 0)
(throw (oneof syntax-error))))) (return (set-of character #?0000))
(throw syntax-error)))))
(production :class-escape (#\b) class-escape-backspace (production :class-escape (#\b) class-escape-backspace
(acceptance-set (set-of character #?0008))) (acceptance-set (set-of character #?0008)))
(production :class-escape (:character-escape) class-escape-character-escape (production :class-escape (:character-escape) class-escape-character-escape
@ -586,43 +605,41 @@
(defparameter *rg* (lexer-grammar *rl*))) (defparameter *rg* (lexer-grammar *rl*)))
(defun run-regexp (regexp input &key ignore-case multiline span) (eval-when (:load-toplevel :execute)
(let ((exec (first (lexer-parse *rl* regexp)))) (defun run-regexp (regexp input &key ignore-case multiline span)
(dotimes (i (length input) '(failure)) (let ((execute (first (lexer-parse *rl* regexp))))
(let ((result (funcall exec (list input ignore-case multiline span) i))) (dotimes (i (length input) :failure)
(ecase (first result) (let ((result (funcall execute (list 'r:re-input input ignore-case multiline span) i)))
(success (unless (eq result :failure)
(return (list* i (subseq input i (second result)) (cddr result)))) (assert-true (eq (first result) 'r:re-match))
(failure)))))) (return (list* i (subseq input i (second result)) (cddr result)))))))))
#| #|
(values (values
(depict-rtf-to-local-file (depict-rtf-to-local-file
"JS20/RegExpGrammar.rtf" "JS20/RegExpGrammar.rtf"
"Regular Expression Grammar" "Regular Expression Grammar"
#'(lambda (rtf-stream) #'(lambda (rtf-stream)
(depict-world-commands rtf-stream *rw* :visible-semantics nil))) (depict-world-commands rtf-stream *rw* :visible-semantics nil)))
(depict-rtf-to-local-file (depict-rtf-to-local-file
"JS20/RegExpSemantics.rtf" "JS20/RegExpSemantics.rtf"
"Regular Expression Semantics" "Regular Expression Semantics"
#'(lambda (rtf-stream) #'(lambda (rtf-stream)
(depict-world-commands rtf-stream *rw*)))) (depict-world-commands rtf-stream *rw*)))
(depict-html-to-local-file
(values "JS20/RegExpGrammar.html"
(depict-html-to-local-file "Regular Expression Grammar"
"JS20/RegExpGrammar.html" t
"Regular Expression Grammar" #'(lambda (html-stream)
t (depict-world-commands html-stream *rw* :visible-semantics nil))
#'(lambda (html-stream) :external-link-base "notation.html")
(depict-world-commands html-stream *rw* :visible-semantics nil)) (depict-html-to-local-file
:external-link-base "notation.html") "JS20/RegExpSemantics.html"
(depict-html-to-local-file "Regular Expression Semantics"
"JS20/RegExpSemantics.html" t
"Regular Expression Semantics" #'(lambda (html-stream)
t (depict-world-commands html-stream *rw*))
#'(lambda (html-stream) :external-link-base "notation.html"))
(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)) (with-local-output (s "JS20/RegExpGrammar.txt") (print-lexer *rl* s) (print-grammar *rg* s))
@ -630,6 +647,7 @@
(lexer-pparse *rl* "[]+" :trace t) (lexer-pparse *rl* "[]+" :trace t)
(run-regexp "(0x|0)2" "0x20") (run-regexp "(0x|0)2" "0x20")
(run-regexp "(a*)b\\1+c" "aabaaaac") (run-regexp "(a*)b\\1+c" "aabaaaac")
(run-regexp "(a*)b\\1+c" "aabaabaaaac")
(run-regexp "(a*)b\\1+" "baaaac") (run-regexp "(a*)b\\1+" "baaaac")
(run-regexp "b(a+)(a+)?(a+)c" "baaaac") (run-regexp "b(a+)(a+)?(a+)c" "baaaac")
(run-regexp "(((a+)?(b+)?c)*)" "aacbbbcac") (run-regexp "(((a+)?(b+)?c)*)" "aacbbbcac")

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

@ -1,5 +1,5 @@
;;; ;;;
;;; JavaScript 2.0 lexer ;;; JavaScript 2.0 unit lexer
;;; ;;;
;;; Waldemar Horwat (waldemar@acm.org) ;;; Waldemar Horwat (waldemar@acm.org)
;;; ;;;
@ -41,27 +41,26 @@
(%text nil "The start nonterminal is " (:grammar-symbol :unit-pattern) ".") (%text nil "The start nonterminal is " (:grammar-symbol :unit-pattern) ".")
(deftype semantic-exception (oneof syntax-error))
(%print-actions) (%print-actions)
(%section "White Space") (%section "White Space")
(grammar-argument :sigma wsopt wsreq) (grammar-argument :sigma wsopt wsreq)
(%charclass :white-space-character) (%charclass :white-space-character)
(%charclass :line-terminator) (%charclass :line-terminator)
(production :required-white-space (:white-space-character) required-white-space-character) (production :required-white-space (:white-space-character) required-white-space-character)
(production :required-white-space (:line-terminator) required-white-space-line-terminator) (production :required-white-space (:line-terminator) required-white-space-line-terminator)
(production :required-white-space (:required-white-space :white-space-character) required-white-space-more-character) (production :required-white-space (:required-white-space :white-space-character) required-white-space-more-character)
(production :required-white-space (:required-white-space :line-terminator) required-white-space-more-line-terminator) (production :required-white-space (:required-white-space :line-terminator) required-white-space-more-line-terminator)
(production (:white-space :sigma) (:required-white-space) white-space-required-white-space) (production (:white-space :sigma) (:required-white-space) white-space-required-white-space)
(production (:white-space wsopt) () white-space-empty) (production (:white-space wsopt) () white-space-empty)
(%section "Unit Patterns") (%section "Unit Patterns")
(rule :unit-pattern ((value unit-list)) (rule :unit-pattern ((value unit-list))
(production :unit-pattern ((:white-space wsopt) :unit-quotient) unit-pattern-quotient (production :unit-pattern ((:white-space wsopt) :unit-quotient) unit-pattern-quotient
(value (value :unit-quotient)))) (value (value :unit-quotient))))
@ -86,18 +85,16 @@
(production (:unit-factor :sigma) (#\1 (:white-space wsopt) #\^ (:white-space wsopt) :signed-integer (:white-space :sigma)) unit-factor-one-exponent (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))) (value (vector-of unit-factor)))
(production (:unit-factor :sigma) (:identifier (:white-space :sigma)) unit-factor-identifier (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 (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-list (vector unit-factor))
(deftype unit-factor (tuple (identifier string) (exponent integer)))
(define (unit-reciprocal (u unit-list)) unit-list (define (unit-reciprocal (value unit-list)) unit-list
(if (empty u) (return (map value f (tag unit-factor (& identifier f) (neg (& exponent f))))))
(vector-of unit-factor)
(let ((f unit-factor (nth u 0)))
(append (vector (tuple unit-factor (& identifier f) (neg (& exponent f)))) (subseq u 1)))))
(%print-actions) (%print-actions)
@ -146,41 +143,39 @@
"JS20/UnitCharClasses.rtf" "JS20/UnitCharClasses.rtf"
"JavaScript 2 Unit Character Classes" "JavaScript 2 Unit Character Classes"
#'(lambda (rtf-stream) #'(lambda (rtf-stream)
(depict-paragraph (rtf-stream ':grammar-header) (depict-paragraph (rtf-stream :grammar-header)
(depict rtf-stream "Character Classes")) (depict rtf-stream "Character Classes"))
(dolist (charclass (lexer-charclasses *ul*)) (dolist (charclass (lexer-charclasses *ul*))
(depict-charclass rtf-stream charclass)) (depict-charclass rtf-stream charclass))
(depict-paragraph (rtf-stream ':grammar-header) (depict-paragraph (rtf-stream :grammar-header)
(depict rtf-stream "Grammar")) (depict rtf-stream "Grammar"))
(depict-grammar rtf-stream *ug*))) (depict-grammar rtf-stream *ug*)))
(values (values
(depict-rtf-to-local-file (depict-rtf-to-local-file
"JS20/UnitGrammar.rtf" "JS20/UnitGrammar.rtf"
"JavaScript 2 Unit Grammar" "JavaScript 2 Unit Grammar"
#'(lambda (rtf-stream) #'(lambda (rtf-stream)
(depict-world-commands rtf-stream *uw* :visible-semantics nil))) (depict-world-commands rtf-stream *uw* :visible-semantics nil)))
(depict-rtf-to-local-file (depict-rtf-to-local-file
"JS20/UnitSemantics.rtf" "JS20/UnitSemantics.rtf"
"JavaScript 2 Unit Semantics" "JavaScript 2 Unit Semantics"
#'(lambda (rtf-stream) #'(lambda (rtf-stream)
(depict-world-commands rtf-stream *uw*)))) (depict-world-commands rtf-stream *uw*)))
(depict-html-to-local-file
(values "JS20/UnitGrammar.html"
(depict-html-to-local-file "JavaScript 2 Unit Grammar"
"JS20/UnitGrammar.html" t
"JavaScript 2 Unit Grammar" #'(lambda (rtf-stream)
t (depict-world-commands rtf-stream *uw* :visible-semantics nil))
#'(lambda (rtf-stream) :external-link-base "notation.html")
(depict-world-commands rtf-stream *uw* :visible-semantics nil)) (depict-html-to-local-file
:external-link-base "notation.html") "JS20/UnitSemantics.html"
(depict-html-to-local-file "JavaScript 2 Unit Semantics"
"JS20/UnitSemantics.html" t
"JavaScript 2 Unit Semantics" #'(lambda (rtf-stream)
t (depict-world-commands rtf-stream *uw*))
#'(lambda (rtf-stream) :external-link-base "notation.html"))
(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)) (with-local-output (s "JS20/UnitGrammar.txt") (print-lexer *ul* s) (print-grammar *ug* s))

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

@ -308,24 +308,24 @@
; Emit markup paragraphs for the lexer charclass. ; Emit markup paragraphs for the lexer charclass.
(defun depict-charclass (markup-stream 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)) (let ((nonterminal (charclass-nonterminal charclass))
(expr (charclass-charset-source charclass))) (expr (charclass-charset-source charclass)))
(if (and (consp expr) (eq (first expr) '++)) (if (and (consp expr) (eq (first expr) '++))
(let* ((subexprs (rest expr)) (let* ((subexprs (rest expr))
(length (length subexprs))) (length (length subexprs)))
(depict-paragraph (markup-stream ':grammar-lhs) (depict-paragraph (markup-stream :grammar-lhs)
(depict-general-nonterminal markup-stream nonterminal :definition) (depict-general-nonterminal markup-stream nonterminal :definition)
(depict markup-stream " " ':derives-10)) (depict markup-stream " " :derives-10))
(dotimes (i length) (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) (if (zerop i)
(depict markup-stream ':tab3) (depict markup-stream :tab3)
(depict markup-stream "|" ':tab2)) (depict markup-stream "|" :tab2))
(depict-charset-source markup-stream (nth i subexprs))))) (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-general-nonterminal markup-stream (charclass-nonterminal charclass) :definition)
(depict markup-stream " " ':derives-10 " ") (depict markup-stream " " :derives-10 " ")
(depict-charset-source markup-stream expr)))))) (depict-charset-source markup-stream expr))))))
@ -589,10 +589,10 @@
#'(lambda (component) #'(lambda (component)
(when (consp component) (when (consp component)
(let ((tag (first component))) (let ((tag (first component)))
(when (eq tag ':-) (when (eq tag :-)
(setq component (list* ':-- (rest component) (rest component))) (setq component (list* :-- (rest component) (rest component)))
(setq tag ':--)) (setq tag :--))
(when (eq tag ':--) (when (eq tag :--)
(setq component (setq component
(list* tag (list* tag
(second component) (second component)
@ -638,7 +638,7 @@
(production-number 0)) (production-number 0))
(dolist (action (charclass-actions charclass)) (dolist (action (charclass-actions charclass))
(let ((lexer-action (cdr action))) (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))) (do ((charset (charclass-charset charclass)))
((charset-empty? charset)) ((charset-empty? charset))
(let* ((partition-name (if (charset-infinite? charset) (let* ((partition-name (if (charset-infinite? charset)
@ -661,7 +661,7 @@
((eql t) 'true) ((eql t) 'true)
(t (error "Cannot infer the type of ~S's result ~S" lexer-action-function result)))) (t (error "Cannot infer the type of ~S's result ~S" lexer-action-function result))))
(list (lexer-action-name lexer-action) partition-name)))) (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))))))) (setq charset (charset-difference charset partition-charset)))))))
(let ((partition-commands (let ((partition-commands
@ -670,7 +670,7 @@
(mapcan #'(lambda (lexer-action) (mapcan #'(lambda (lexer-action)
(let ((lexer-action-name (lexer-action-name lexer-action))) (let ((lexer-action-name (lexer-action-name lexer-action)))
(list (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))))) (list 'terminal-action lexer-action-name partition-name (lexer-action-function lexer-action)))))
(partition-lexer-actions (gethash partition-name (lexer-partitions lexer))))) (partition-lexer-actions (gethash partition-name (lexer-partitions lexer)))))
(lexer-partition-names lexer)))) (lexer-partition-names lexer))))

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

@ -52,7 +52,7 @@
(push (if (equal dir-name "..") :up dir-name) directories) (push (if (equal dir-name "..") :up dir-name) directories)
(setq filename (subseq filename (1+ slash)))) (setq filename (subseq filename (1+ slash))))
(return (if directories (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 filename
#+lispworks (make-pathname :name filename :type "lisp")))))))) #+lispworks (make-pathname :name filename :type "lisp"))))))))

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

@ -197,8 +197,9 @@
(incf (logical-position-position logical-position) width))) (incf (logical-position-position logical-position) width)))
(defstruct (soft-break (:constructor make-soft-break (width))) (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 (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 ; 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. ; Return a freshly consed markup list for a hard line break followed by indent spaces.
(defun hard-break-markup (indent) (defun hard-break-markup (indent)
(if (zerop indent) (if (zerop indent)
(list ':new-line) (list :new-line)
(list ':new-line (make-string indent :initial-element #\space :element-type #-mcl 'character #+mcl 'base-character)))) (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 ; Destructively replace any soft-break that appears in a car position in the tree
; with a line break followed by indent spaces. ; 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) (defun expand-soft-breaks (tree indent)
(substitute-soft-breaks (substitute-soft-breaks
tree tree
#'(lambda (soft-break) #'(lambda (soft-break)
(declare (ignore soft-break)) (nconc (hard-break-markup indent)
(hard-break-markup indent)))) (copy-list (soft-break-groups soft-break))))))
;;; ------------------------------------------------------------------------------------------------------ ;;; ------------------------------------------------------------------------------------------------------
@ -451,7 +454,7 @@
(old-tail (markup-stream-tail markup-stream))) (old-tail (markup-stream-tail markup-stream)))
(setf (markup-stream-logical-position markup-stream) inner-logical-position) (setf (markup-stream-logical-position markup-stream) inner-logical-position)
(when *show-logical-blocks* (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 (prog1
(funcall emitter markup-stream) (funcall emitter markup-stream)
(when *show-logical-blocks* (when *show-logical-blocks*
@ -479,8 +482,10 @@
(remove-soft-breaks tree) (remove-soft-breaks tree)
(incf (logical-position-position logical-position) inner-count)) (incf (logical-position-position logical-position) inner-count))
(t (t
(assert-true tree) (let ((tail (markup-stream-tail markup-stream)))
(expand-soft-breaks tree cumulative-indent) (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)) (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-position logical-position) (logical-position-minimal-position inner-logical-position))
(setf (logical-position-surplus logical-position) 0)))) (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. ; 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 t or omitted, the line break is unconditional.
; If width is nil, do nothing. ; 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. ; 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*)) (assert-true (>= (markup-stream-level markup-stream) *markup-stream-content-level*))
(when width (when width
(let* ((logical-position (markup-stream-logical-position markup-stream)) (let* ((logical-position (markup-stream-logical-position markup-stream))
(indent (logical-position-indent logical-position))) (indent (logical-position-indent logical-position)))
(if (eq width t) (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 (progn
(incf (logical-position-n-soft-breaks logical-position)) (incf (logical-position-n-soft-breaks logical-position))
(incf (logical-position-position logical-position) width) (incf (logical-position-position logical-position) width)
@ -521,7 +531,7 @@
(setf (logical-position-surplus logical-position) surplus)) (setf (logical-position-surplus logical-position) surplus))
(when *show-logical-blocks* (when *show-logical-blocks*
(markup-stream-append1 markup-stream '(:invisible :bullet))) (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. ; 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-logical-block (markup-stream indent)
(depict-break markup-stream prefix-break) (depict-break markup-stream prefix-break)
(emit-element markup-stream list))) (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))) (t (depict-item-or-list markup-stream empty)))
(depict-item-or-list markup-stream suffix))) (depict-item-or-list markup-stream suffix)))
@ -580,21 +590,21 @@
(let ((code (char-code char))) (let ((code (char-code char)))
(if (and (>= code 32) (< code 127) (not (member char escape-list))) (if (and (>= code 32) (< code 127) (not (member char escape-list)))
(depict markup-stream (string char)) (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*)) (let ((name (or (cdr (assoc code *character-names*))
(format nil "u~4,'0X" code)))) (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. ; Emit markup for the given string, enclosing it in curly double quotes.
; The markup-stream should be set to normal formatting. ; The markup-stream should be set to normal formatting.
(defun depict-string (markup-stream string) (defun depict-string (markup-stream string)
(depict markup-stream ':left-double-quote) (depict markup-stream :left-double-quote)
(unless (equal string "") (unless (equal string "")
(depict-char-style (markup-stream ':character-literal) (depict-char-style (markup-stream :character-literal)
(dotimes (i (length string)) (dotimes (i (length string))
(depict-character markup-stream (char string i) nil)))) (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. ; Emit markup for the given integer, displaying it in decimal.
(defun depict-integer (markup-stream i) (defun depict-integer (markup-stream i)
(when (minusp i)
(depict markup-stream :minus)
(setq i (- i)))
(depict markup-stream (format nil "~D" i))) (depict markup-stream (format nil "~D" i)))

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

@ -667,7 +667,6 @@
#'(lambda (production) #'(lambda (production)
(setf (production-actions production) nil) (setf (production-actions production) nil)
(setf (production-n-action-args production) nil) (setf (production-n-action-args production) nil)
(setf (production-evaluator-code production) nil)
(setf (production-evaluator production) nil))) (setf (production-evaluator production) nil)))
(clrhash (grammar-terminal-actions grammar)))) (clrhash (grammar-terminal-actions grammar))))
@ -736,7 +735,7 @@
; Define action action-symbol, when called on the production with the given name, ; Define action action-symbol, when called on the production with the given name,
; to be action-expr. The action should have been declared already. ; 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))) (dolist (production (general-production-productions (grammar-general-production grammar production-name)))
(let ((definition (assoc action-symbol (production-actions production) :test #'eq))) (let ((definition (assoc action-symbol (production-actions production) :test #'eq)))
(cond (cond
@ -744,7 +743,7 @@
(error "Attempt to define action ~S on ~S, which hasn't been declared yet" action-symbol production-name)) (error "Attempt to define action ~S on ~S, which hasn't been declared yet" action-symbol production-name))
((cdr definition) ((cdr definition)
(error "Duplicate definition of action ~S on ~S" action-symbol production-name)) (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, ; Define action action-symbol, when called on the given terminal,

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

@ -124,12 +124,15 @@
((:infinity 1) u 8734 \' 176) ((:infinity 1) u 8734 \' 176)
((:left-single-quote 1) lquote) ((:left-single-quote 1) lquote)
((:right-single-quote 1) rquote) ((:right-single-quote 1) rquote)
((:apostrophe 1) rquote)
((:left-double-quote 1) ldblquote) ((:left-double-quote 1) ldblquote)
((:right-double-quote 1) rdblquote) ((:right-double-quote 1) rdblquote)
((:left-angle-quote 1) u 171 \' 199) ((:left-angle-quote 1) u 171 \' 199)
((:right-angle-quote 1) u 187 \' 200) ((: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))) ((: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))) ((: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))) ((: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))) ((: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))) ((: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))) ((: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))) ((: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))) ((: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-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-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))) ((: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))) ((:alpha 1) (field (* fldinst "SYMBOL 97 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
@ -285,21 +293,25 @@
(:type-name-num 42) (:type-name-num 42)
(:type-name cs :type-name-num scaps :times :red :no-language) (: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-num 43)
(:field-name cs :field-name-num :helvetica :red :no-language) (:field-name cs :field-name-num :helvetica :no-language)
((+ :styles) (* :field-name additive sbasedon :type-expression-num "Field Name;")) ((+ :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) (:global-variable cs :global-variable-num i :times :dark-green :no-language)
((+ :styles) (* :global-variable additive sbasedon :default-paragraph-font-num "Global Variable;")) ((+ :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) (:local-variable cs :local-variable-num i :times :green :no-language)
((+ :styles) (* :local-variable additive sbasedon :default-paragraph-font-num "Local Variable;")) ((+ :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) (:action-name cs :action-name-num :zapf-chancery :purple :no-language)
((+ :styles) (* :action-name additive sbasedon :default-paragraph-font-num "Action Name;")) ((+ :styles) (* :action-name additive sbasedon :default-paragraph-font-num "Action Name;"))
@ -344,6 +356,8 @@
((:vector-append 2) :circle-plus-10) ((:vector-append 2) :circle-plus-10)
((:tuple-begin 1) (b :left-triangle-bracket-10)) ((:tuple-begin 1) (b :left-triangle-bracket-10))
((:tuple-end 1) (b :right-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")) ((:true 4) (:global-variable "true"))
((:false 5) (:global-variable "false")) ((:false 5) (:global-variable "false"))
((:unique 6) (:semantic-keyword "unique")) ((:unique 6) (:semantic-keyword "unique"))
@ -445,12 +459,15 @@
((:infinity 1) u 8734 \' 176) ((:infinity 1) u 8734 \' 176)
((:left-single-quote 1) lquote) ((:left-single-quote 1) lquote)
((:right-single-quote 1) rquote) ((:right-single-quote 1) rquote)
((:apostrophe 1) rquote)
((:left-double-quote 1) ldblquote) ((:left-double-quote 1) ldblquote)
((:right-double-quote 1) rdblquote) ((:right-double-quote 1) rdblquote)
((:left-angle-quote 1) u 171 \' 199) ((:left-angle-quote 1) u 171 \' 199)
((:right-angle-quote 1) u 187 \' 200) ((: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))) ((: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))) ((: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))) ((: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))) ((: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))) ((: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))) ((: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))) ((: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))) ((: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-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-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))) ((: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))) ((:alpha 1) (field (* fldinst "SYMBOL 97 \\f \"Symbol\" \\s 10") (fldrslt :symbol :10-pt)))
@ -600,29 +622,35 @@
(:type-name-num 42) (:type-name-num 42)
(:type-name cs :type-name-num scaps :times :red :no-language) (: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-num 43)
(:field-name cs :field-name-num :helvetica :red :no-language) (:field-name cs :field-name-num :helvetica :no-language)
((+ :styles) (* :field-name additive sbasedon :type-expression-num "Field Name;")) ((+ :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) (:global-variable cs :global-variable-num i :times :dark-green :no-language)
((+ :styles) (* :global-variable additive sbasedon :default-paragraph-font-num "Global Variable;")) ((+ :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) (:local-variable cs :local-variable-num i :times :green :no-language)
((+ :styles) (* :local-variable additive sbasedon :default-paragraph-font-num "Local Variable;")) ((+ :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) (:action-name cs :action-name-num :zapf-chancery :purple :no-language)
((+ :styles) (* :action-name additive sbasedon :default-paragraph-font-num "Action Name;")) ((+ :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) (:id-name cs :id-name-num scaps :helvetica :no-language)
((+ :styles) (* :id-name additive sbasedon :default-paragraph-font-num "Id Name;")) ((+ :styles) (* :id-name additive sbasedon :default-paragraph-font-num "Id Name;"))
|#
(:variable-num 50) (:variable-num 50)
(:variable cs :variable-num i :palatino :color336600 :no-language) (:variable cs :variable-num i :palatino :color336600 :no-language)
((+ :styles) (* :variable additive sbasedon :default-paragraph-font-num "Variable;")) ((+ :styles) (* :variable additive sbasedon :default-paragraph-font-num "Variable;"))
@ -1059,14 +1087,14 @@
(let* ((top-rtf-stream (make-top-level-rtf-stream rtf-definitions)) (let* ((top-rtf-stream (make-top-level-rtf-stream rtf-definitions))
(rtf-stream (make-rtf-stream (markup-stream-env top-rtf-stream) *markup-stream-paragraph-level*)) (rtf-stream (make-rtf-stream (markup-stream-env top-rtf-stream) *markup-stream-paragraph-level*))
(time (get-universal-time))) (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))) (let ((info (generate-document-info title *rtf-author* *rtf-company* time)))
(when info (when info
(markup-stream-append1 rtf-stream info))) (markup-stream-append1 rtf-stream info)))
(markup-stream-append1 rtf-stream ':docfmt) (markup-stream-append1 rtf-stream :docfmt)
(markup-stream-append1 rtf-stream ':reset-section) (markup-stream-append1 rtf-stream :reset-section)
(markup-stream-append1 rtf-stream (generate-header-group title time)) (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) (funcall emitter rtf-stream)
(markup-stream-append1 top-rtf-stream (markup-stream-unexpanded-output rtf-stream)) (markup-stream-append1 top-rtf-stream (markup-stream-unexpanded-output rtf-stream))
top-rtf-stream)) top-rtf-stream))
@ -1098,7 +1126,7 @@
(assert-true (= (markup-stream-level rtf-stream) *markup-stream-paragraph-level*)) (assert-true (= (markup-stream-level rtf-stream) *markup-stream-paragraph-level*))
(assert-true (and paragraph-style (symbolp paragraph-style))) (assert-true (and paragraph-style (symbolp paragraph-style)))
(unless (eq paragraph-style (rtf-stream-style rtf-stream)) (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)) (markup-stream-append1 rtf-stream paragraph-style))
(setf (rtf-stream-style rtf-stream) nil) (setf (rtf-stream-style rtf-stream) nil)
(setf (markup-stream-level rtf-stream) *markup-stream-content-level*) (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 (markup-stream-level rtf-stream) *markup-stream-paragraph-level*)
(setf (rtf-stream-style rtf-stream) paragraph-style) (setf (rtf-stream-style rtf-stream) paragraph-style)
(setf (markup-stream-logical-position rtf-stream) nil) (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) (defmethod depict-char-style-f ((rtf-stream rtf-stream) char-style emitter)