Updated to work under Allegro Common Lisp
This commit is contained in:
waldemar%netscape.com
Родитель
db611ebed7
Коммит
134c6fefaf
|
|
@ -345,7 +345,7 @@
|
|||
(defun grammar-symbol-= (grammar-symbol1 grammar-symbol2)
|
||||
(eql grammar-symbol1 grammar-symbol2))
|
||||
; A version of grammar-symbol-= suitable for being the test function for hash tables.
|
||||
(defconstant *grammar-symbol-=* #'eql)
|
||||
(defparameter *grammar-symbol-=* #'eql)
|
||||
|
||||
|
||||
; Return the general-grammar-symbol's symbol. Return it unchanged if it is not
|
||||
|
|
|
|||
|
|
@ -322,7 +322,7 @@
|
|||
; Write html to the text file with the given name (relative to the
|
||||
; local directory).
|
||||
(defun write-html-to-local-file (filename html)
|
||||
(with-open-file (stream (merge-pathnames filename *semantic-engine-directory*)
|
||||
(with-open-file (stream (filename-to-semantic-engine-pathname filename)
|
||||
:direction :output
|
||||
:if-exists :supersede
|
||||
#+mcl :mac-file-creator #+mcl "MOSS")
|
||||
|
|
|
|||
|
|
@ -1,400 +0,0 @@
|
|||
;;;
|
||||
;;; Sample JavaScript 1.x grammar
|
||||
;;;
|
||||
;;; Waldemar Horwat (waldemar@acm.org)
|
||||
;;;
|
||||
|
||||
(declaim (optimize (debug 3)))
|
||||
|
||||
(progn
|
||||
(defparameter *jw*
|
||||
(generate-world
|
||||
"J"
|
||||
'((grammar code-grammar :lr-1 :program)
|
||||
|
||||
(%section "Expressions")
|
||||
(grammar-argument :alpha normal initial)
|
||||
(grammar-argument :beta allow-in no-in)
|
||||
|
||||
(%subsection "Primary Expressions")
|
||||
(production (:primary-expression :alpha) (:simple-expression) primary-expression-simple-expression)
|
||||
(production (:primary-expression normal) (:function-expression) primary-expression-function-expression)
|
||||
(production (:primary-expression normal) (:object-literal) primary-expression-object-literal)
|
||||
|
||||
(production :simple-expression (this) simple-expression-this)
|
||||
(production :simple-expression (null) simple-expression-null)
|
||||
(production :simple-expression (true) simple-expression-true)
|
||||
(production :simple-expression (false) simple-expression-false)
|
||||
(production :simple-expression ($number) simple-expression-number)
|
||||
(production :simple-expression ($string) simple-expression-string)
|
||||
(production :simple-expression ($identifier) simple-expression-identifier)
|
||||
(production :simple-expression ($regular-expression) simple-expression-regular-expression)
|
||||
(production :simple-expression (:parenthesized-expression) simple-expression-parenthesized-expression)
|
||||
(production :simple-expression (:array-literal) simple-expression-array-literal)
|
||||
|
||||
(production :parenthesized-expression (\( (:expression normal allow-in) \)) parenthesized-expression-expression)
|
||||
|
||||
|
||||
(%subsection "Function Expressions")
|
||||
(production :function-expression (:anonymous-function) function-expression-anonymous-function)
|
||||
(production :function-expression (:named-function) function-expression-named-function)
|
||||
|
||||
|
||||
(%subsection "Object Literals")
|
||||
(production :object-literal (\{ \}) object-literal-empty)
|
||||
(production :object-literal (\{ :field-list \}) object-literal-list)
|
||||
|
||||
(production :field-list (:literal-field) field-list-one)
|
||||
(production :field-list (:field-list \, :literal-field) field-list-more)
|
||||
|
||||
(production :literal-field ($identifier \: (:assignment-expression normal allow-in)) literal-field-assignment-expression)
|
||||
|
||||
|
||||
(%subsection "Array Literals")
|
||||
(production :array-literal ([ ]) array-literal-empty)
|
||||
(production :array-literal ([ :element-list ]) array-literal-list)
|
||||
|
||||
(production :element-list (:literal-element) element-list-one)
|
||||
(production :element-list (:element-list \, :literal-element) element-list-more)
|
||||
|
||||
(production :literal-element ((:assignment-expression normal allow-in)) literal-element-assignment-expression)
|
||||
|
||||
|
||||
(%subsection "Left-Side Expressions")
|
||||
(production (:left-side-expression :alpha) ((:call-expression :alpha)) left-side-expression-call-expression)
|
||||
(production (:left-side-expression :alpha) (:short-new-expression) left-side-expression-short-new-expression)
|
||||
|
||||
(production (:call-expression :alpha) ((:primary-expression :alpha)) call-expression-primary-expression)
|
||||
(production (:call-expression :alpha) (:full-new-expression) call-expression-full-new-expression)
|
||||
(production (:call-expression :alpha) ((:call-expression :alpha) :member-operator) call-expression-member-operator)
|
||||
(production (:call-expression :alpha) ((:call-expression :alpha) :arguments) call-expression-call)
|
||||
|
||||
(production :full-new-expression (new :full-new-subexpression :arguments) full-new-expression-new)
|
||||
|
||||
(production :short-new-expression (new :short-new-subexpression) short-new-expression-new)
|
||||
|
||||
(production :full-new-subexpression ((:primary-expression normal)) full-new-subexpression-primary-expression)
|
||||
(production :full-new-subexpression (:full-new-expression) full-new-subexpression-full-new-expression)
|
||||
(production :full-new-subexpression (:full-new-subexpression :member-operator) full-new-subexpression-member-operator)
|
||||
|
||||
(production :short-new-subexpression (:full-new-subexpression) short-new-subexpression-new-full)
|
||||
(production :short-new-subexpression (:short-new-expression) short-new-subexpression-new-short)
|
||||
|
||||
(production :member-operator ([ (:expression normal allow-in) ]) member-operator-array)
|
||||
(production :member-operator (\. $identifier) member-operator-property)
|
||||
|
||||
(production :arguments (\( \)) arguments-empty)
|
||||
(production :arguments (\( :argument-list \)) arguments-list)
|
||||
|
||||
(production :argument-list ((:assignment-expression normal allow-in)) argument-list-one)
|
||||
(production :argument-list (:argument-list \, (:assignment-expression normal allow-in)) argument-list-more)
|
||||
|
||||
|
||||
(%subsection "Postfix Operators")
|
||||
(production (:postfix-expression :alpha) ((:left-side-expression :alpha)) postfix-expression-left-side-expression)
|
||||
(production (:postfix-expression :alpha) ((:left-side-expression :alpha) ++) postfix-expression-increment)
|
||||
(production (:postfix-expression :alpha) ((:left-side-expression :alpha) --) postfix-expression-decrement)
|
||||
|
||||
|
||||
(%subsection "Unary Operators")
|
||||
(production (:unary-expression :alpha) ((:postfix-expression :alpha)) unary-expression-postfix)
|
||||
(production (:unary-expression :alpha) (delete (:left-side-expression normal)) unary-expression-delete)
|
||||
(production (:unary-expression :alpha) (void (:unary-expression normal)) unary-expression-void)
|
||||
(production (:unary-expression :alpha) (typeof (:unary-expression normal)) unary-expression-typeof)
|
||||
(production (:unary-expression :alpha) (++ (:left-side-expression normal)) unary-expression-increment)
|
||||
(production (:unary-expression :alpha) (-- (:left-side-expression normal)) unary-expression-decrement)
|
||||
(production (:unary-expression :alpha) (+ (:unary-expression normal)) unary-expression-plus)
|
||||
(production (:unary-expression :alpha) (- (:unary-expression normal)) unary-expression-minus)
|
||||
(production (:unary-expression :alpha) (~ (:unary-expression normal)) unary-expression-bitwise-not)
|
||||
(production (:unary-expression :alpha) (! (:unary-expression normal)) unary-expression-logical-not)
|
||||
|
||||
|
||||
(%subsection "Multiplicative Operators")
|
||||
(production (:multiplicative-expression :alpha) ((:unary-expression :alpha)) multiplicative-expression-unary)
|
||||
(production (:multiplicative-expression :alpha) ((:multiplicative-expression :alpha) * (:unary-expression normal)) multiplicative-expression-multiply)
|
||||
(production (:multiplicative-expression :alpha) ((:multiplicative-expression :alpha) / (:unary-expression normal)) multiplicative-expression-divide)
|
||||
(production (:multiplicative-expression :alpha) ((:multiplicative-expression :alpha) % (:unary-expression normal)) multiplicative-expression-remainder)
|
||||
|
||||
|
||||
(%subsection "Additive Operators")
|
||||
(production (:additive-expression :alpha) ((:multiplicative-expression :alpha)) additive-expression-multiplicative)
|
||||
(production (:additive-expression :alpha) ((:additive-expression :alpha) + (:multiplicative-expression normal)) additive-expression-add)
|
||||
(production (:additive-expression :alpha) ((:additive-expression :alpha) - (:multiplicative-expression normal)) additive-expression-subtract)
|
||||
|
||||
|
||||
(%subsection "Bitwise Shift Operators")
|
||||
(production (:shift-expression :alpha) ((:additive-expression :alpha)) shift-expression-additive)
|
||||
(production (:shift-expression :alpha) ((:shift-expression :alpha) << (:additive-expression normal)) shift-expression-left)
|
||||
(production (:shift-expression :alpha) ((:shift-expression :alpha) >> (:additive-expression normal)) shift-expression-right-signed)
|
||||
(production (:shift-expression :alpha) ((:shift-expression :alpha) >>> (:additive-expression normal)) shift-expression-right-unsigned)
|
||||
|
||||
|
||||
(%subsection "Relational Operators")
|
||||
(exclude (:relational-expression initial no-in))
|
||||
(production (:relational-expression :alpha :beta) ((:shift-expression :alpha)) relational-expression-shift)
|
||||
(production (:relational-expression :alpha :beta) ((:relational-expression :alpha :beta) < (:shift-expression normal)) relational-expression-less)
|
||||
(production (:relational-expression :alpha :beta) ((:relational-expression :alpha :beta) > (:shift-expression normal)) relational-expression-greater)
|
||||
(production (:relational-expression :alpha :beta) ((:relational-expression :alpha :beta) <= (:shift-expression normal)) relational-expression-less-or-equal)
|
||||
(production (:relational-expression :alpha :beta) ((:relational-expression :alpha :beta) >= (:shift-expression normal)) relational-expression-greater-or-equal)
|
||||
(production (:relational-expression :alpha :beta) ((:relational-expression :alpha :beta) instanceof (:shift-expression normal)) relational-expression-instanceof)
|
||||
(production (:relational-expression :alpha allow-in) ((:relational-expression :alpha allow-in) in (:shift-expression normal)) relational-expression-in)
|
||||
|
||||
|
||||
(%subsection "Equality Operators")
|
||||
(exclude (:equality-expression initial no-in))
|
||||
(production (:equality-expression :alpha :beta) ((:relational-expression :alpha :beta)) equality-expression-relational)
|
||||
(production (:equality-expression :alpha :beta) ((:equality-expression :alpha :beta) == (:relational-expression normal :beta)) equality-expression-equal)
|
||||
(production (:equality-expression :alpha :beta) ((:equality-expression :alpha :beta) != (:relational-expression normal :beta)) equality-expression-not-equal)
|
||||
(production (:equality-expression :alpha :beta) ((:equality-expression :alpha :beta) === (:relational-expression normal :beta)) equality-expression-strict-equal)
|
||||
(production (:equality-expression :alpha :beta) ((:equality-expression :alpha :beta) !== (:relational-expression normal :beta)) equality-expression-strict-not-equal)
|
||||
|
||||
|
||||
(%subsection "Binary Bitwise Operators")
|
||||
(exclude (:bitwise-and-expression initial no-in))
|
||||
(production (:bitwise-and-expression :alpha :beta) ((:equality-expression :alpha :beta)) bitwise-and-expression-equality)
|
||||
(production (:bitwise-and-expression :alpha :beta) ((:bitwise-and-expression :alpha :beta) & (:equality-expression normal :beta)) bitwise-and-expression-and)
|
||||
|
||||
(exclude (:bitwise-xor-expression initial no-in))
|
||||
(production (:bitwise-xor-expression :alpha :beta) ((:bitwise-and-expression :alpha :beta)) bitwise-xor-expression-bitwise-and)
|
||||
(production (:bitwise-xor-expression :alpha :beta) ((:bitwise-xor-expression :alpha :beta) ^ (:bitwise-and-expression normal :beta)) bitwise-xor-expression-xor)
|
||||
|
||||
(exclude (:bitwise-or-expression initial no-in))
|
||||
(production (:bitwise-or-expression :alpha :beta) ((:bitwise-xor-expression :alpha :beta)) bitwise-or-expression-bitwise-xor)
|
||||
(production (:bitwise-or-expression :alpha :beta) ((:bitwise-or-expression :alpha :beta) \| (:bitwise-xor-expression normal :beta)) bitwise-or-expression-or)
|
||||
|
||||
|
||||
(%subsection "Binary Logical Operators")
|
||||
(exclude (:logical-and-expression initial no-in))
|
||||
(production (:logical-and-expression :alpha :beta) ((:bitwise-or-expression :alpha :beta)) logical-and-expression-bitwise-or)
|
||||
(production (:logical-and-expression :alpha :beta) ((:logical-and-expression :alpha :beta) && (:bitwise-or-expression normal :beta)) logical-and-expression-and)
|
||||
|
||||
(exclude (:logical-or-expression initial no-in))
|
||||
(production (:logical-or-expression :alpha :beta) ((:logical-and-expression :alpha :beta)) logical-or-expression-logical-and)
|
||||
(production (:logical-or-expression :alpha :beta) ((:logical-or-expression :alpha :beta) \|\| (:logical-and-expression normal :beta)) logical-or-expression-or)
|
||||
|
||||
|
||||
(%subsection "Conditional Operator")
|
||||
(exclude (:conditional-expression initial no-in))
|
||||
(production (:conditional-expression :alpha :beta) ((:logical-or-expression :alpha :beta)) conditional-expression-logical-or)
|
||||
(production (:conditional-expression :alpha :beta) ((:logical-or-expression :alpha :beta) ? (:assignment-expression normal :beta) \: (:assignment-expression normal :beta)) conditional-expression-conditional)
|
||||
|
||||
|
||||
(%subsection "Assignment Operators")
|
||||
(exclude (:assignment-expression initial no-in))
|
||||
(production (:assignment-expression :alpha :beta) ((:conditional-expression :alpha :beta)) assignment-expression-conditional)
|
||||
(production (:assignment-expression :alpha :beta) ((:left-side-expression :alpha) = (:assignment-expression normal :beta)) assignment-expression-assignment)
|
||||
(production (:assignment-expression :alpha :beta) ((:left-side-expression :alpha) :compound-assignment (:assignment-expression normal :beta)) assignment-expression-compound)
|
||||
|
||||
(production :compound-assignment (*=) compound-assignment-multiply)
|
||||
(production :compound-assignment (/=) compound-assignment-divide)
|
||||
(production :compound-assignment (%=) compound-assignment-remainder)
|
||||
(production :compound-assignment (+=) compound-assignment-add)
|
||||
(production :compound-assignment (-=) compound-assignment-subtract)
|
||||
(production :compound-assignment (<<=) compound-assignment-shift-left)
|
||||
(production :compound-assignment (>>=) compound-assignment-shift-right)
|
||||
(production :compound-assignment (>>>=) compound-assignment-shift-right-unsigned)
|
||||
(production :compound-assignment (&=) compound-assignment-and)
|
||||
(production :compound-assignment (^=) compound-assignment-or)
|
||||
(production :compound-assignment (\|=) compound-assignment-xor)
|
||||
|
||||
|
||||
(%subsection "Expressions")
|
||||
(exclude (:expression initial no-in))
|
||||
(production (:expression :alpha :beta) ((:assignment-expression :alpha :beta)) expression-assignment)
|
||||
(production (:expression :alpha :beta) ((:expression :alpha :beta) \, (:assignment-expression normal :beta)) expression-comma)
|
||||
|
||||
(production :optional-expression ((:expression normal allow-in)) optional-expression-expression)
|
||||
(production :optional-expression () optional-expression-empty)
|
||||
|
||||
|
||||
(%section "Statements")
|
||||
|
||||
(grammar-argument :omega
|
||||
no-short-if ;optional semicolon, but statement must not end with an if without an else
|
||||
full) ;semicolon required at the end
|
||||
|
||||
(production (:statement :omega) (:empty-statement) statement-empty-statement)
|
||||
(production (:statement :omega) (:expression-statement :optional-semicolon) statement-expression-statement)
|
||||
(production (:statement :omega) (:variable-definition :optional-semicolon) statement-variable-definition)
|
||||
(production (:statement :omega) (:block) statement-block)
|
||||
(production (:statement :omega) ((:labeled-statement :omega)) statement-labeled-statement)
|
||||
(production (:statement :omega) ((:if-statement :omega)) statement-if-statement)
|
||||
(production (:statement :omega) (:switch-statement) statement-switch-statement)
|
||||
(production (:statement :omega) (:do-statement :optional-semicolon) statement-do-statement)
|
||||
(production (:statement :omega) ((:while-statement :omega)) statement-while-statement)
|
||||
(production (:statement :omega) ((:for-statement :omega)) statement-for-statement)
|
||||
(production (:statement :omega) ((:with-statement :omega)) statement-with-statement)
|
||||
(production (:statement :omega) (:continue-statement :optional-semicolon) statement-continue-statement)
|
||||
(production (:statement :omega) (:break-statement :optional-semicolon) statement-break-statement)
|
||||
(production (:statement :omega) (:return-statement :optional-semicolon) statement-return-statement)
|
||||
(production (:statement :omega) (:throw-statement :optional-semicolon) statement-throw-statement)
|
||||
(production (:statement :omega) (:try-statement) statement-try-statement)
|
||||
|
||||
(production :optional-semicolon (\;) optional-semicolon-semicolon)
|
||||
|
||||
|
||||
(%subsection "Empty Statement")
|
||||
(production :empty-statement (\;) empty-statement-semicolon)
|
||||
|
||||
|
||||
(%subsection "Expression Statement")
|
||||
(production :expression-statement ((:expression initial allow-in)) expression-statement-expression)
|
||||
|
||||
|
||||
(%subsection "Variable Definition")
|
||||
(production :variable-definition (var (:variable-declaration-list allow-in)) variable-definition-declaration)
|
||||
|
||||
(production (:variable-declaration-list :beta) ((:variable-declaration :beta)) variable-declaration-list-one)
|
||||
(production (:variable-declaration-list :beta) ((:variable-declaration-list :beta) \, (:variable-declaration :beta)) variable-declaration-list-more)
|
||||
|
||||
(production (:variable-declaration :beta) ($identifier (:variable-initializer :beta)) variable-declaration-initializer)
|
||||
|
||||
(production (:variable-initializer :beta) () variable-initializer-empty)
|
||||
(production (:variable-initializer :beta) (= (:assignment-expression normal :beta)) variable-initializer-assignment-expression)
|
||||
|
||||
|
||||
(%subsection "Block")
|
||||
(production :block ({ :block-statements }) block-block-statements)
|
||||
|
||||
(production :block-statements () block-statements-one)
|
||||
(production :block-statements (:block-statements-prefix) block-statements-more)
|
||||
|
||||
(production :block-statements-prefix ((:statement full)) block-statements-prefix-one)
|
||||
(production :block-statements-prefix (:block-statements-prefix (:statement full)) block-statements-prefix-more)
|
||||
|
||||
|
||||
(%subsection "Labeled Statements")
|
||||
(production (:labeled-statement :omega) ($identifier \: (:statement :omega)) labeled-statement-label)
|
||||
|
||||
|
||||
(%subsection "If Statement")
|
||||
(production (:if-statement full) (if :parenthesized-expression (:statement full)) if-statement-if-then-full)
|
||||
(production (:if-statement :omega) (if :parenthesized-expression (:statement no-short-if)
|
||||
else (:statement :omega)) if-statement-if-then-else)
|
||||
|
||||
|
||||
(%subsection "Switch Statement")
|
||||
(production :switch-statement (switch :parenthesized-expression { }) switch-statement-empty)
|
||||
(production :switch-statement (switch :parenthesized-expression { :case-groups :last-case-group }) switch-statement-cases)
|
||||
|
||||
(production :case-groups () case-groups-empty)
|
||||
(production :case-groups (:case-groups :case-group) case-groups-more)
|
||||
|
||||
(production :case-group (:case-guards :block-statements-prefix) case-group-block-statements-prefix)
|
||||
|
||||
(production :last-case-group (:case-guards :block-statements) last-case-group-block-statements)
|
||||
|
||||
(production :case-guards (:case-guard) case-guards-one)
|
||||
(production :case-guards (:case-guards :case-guard) case-guards-more)
|
||||
|
||||
(production :case-guard (case (:expression normal allow-in) \:) case-guard-case)
|
||||
(production :case-guard (default \:) case-guard-default)
|
||||
|
||||
|
||||
(%subsection "Do-While Statement")
|
||||
(production :do-statement (do (:statement full) while :parenthesized-expression) do-statement-do-while)
|
||||
|
||||
|
||||
(%subsection "While Statement")
|
||||
(production (:while-statement :omega) (while :parenthesized-expression (:statement :omega)) while-statement-while)
|
||||
|
||||
|
||||
(%subsection "For Statements")
|
||||
(production (:for-statement :omega) (for \( :for-initializer \; :optional-expression \; :optional-expression \)
|
||||
(:statement :omega)) for-statement-c-style)
|
||||
(production (:for-statement :omega) (for \( :for-in-binding in (:expression normal allow-in) \) (:statement :omega)) for-statement-in)
|
||||
|
||||
(production :for-initializer () for-initializer-empty)
|
||||
(production :for-initializer ((:expression normal no-in)) for-initializer-expression)
|
||||
(production :for-initializer (var (:variable-declaration-list no-in)) for-initializer-variable-declaration)
|
||||
|
||||
(production :for-in-binding ((:left-side-expression normal)) for-in-binding-expression)
|
||||
(production :for-in-binding (var (:variable-declaration no-in)) for-in-binding-variable-declaration)
|
||||
|
||||
|
||||
(%subsection "With Statement")
|
||||
(production (:with-statement :omega) (with :parenthesized-expression (:statement :omega)) with-statement-with)
|
||||
|
||||
|
||||
(%subsection "Continue and Break Statements")
|
||||
(production :continue-statement (continue :optional-label) continue-statement-optional-label)
|
||||
|
||||
(production :break-statement (break :optional-label) break-statement-optional-label)
|
||||
|
||||
(production :optional-label () optional-label-default)
|
||||
(production :optional-label ($identifier) optional-label-identifier)
|
||||
|
||||
|
||||
(%subsection "Return Statement")
|
||||
(production :return-statement (return :optional-expression) return-statement-optional-expression)
|
||||
|
||||
|
||||
(%subsection "Throw Statement")
|
||||
(production :throw-statement (throw (:expression normal allow-in)) throw-statement-throw)
|
||||
|
||||
|
||||
(%subsection "Try Statement")
|
||||
(production :try-statement (try :block :catch-clauses) try-statement-catch-clauses)
|
||||
(production :try-statement (try :block :finally-clause) try-statement-finally-clause)
|
||||
(production :try-statement (try :block :catch-clauses :finally-clause) try-statement-catch-clauses-finally-clause)
|
||||
|
||||
(production :catch-clauses (:catch-clause) catch-clauses-one)
|
||||
(production :catch-clauses (:catch-clauses :catch-clause) catch-clauses-more)
|
||||
|
||||
(production :catch-clause (catch \( $identifier \) :block) catch-clause-block)
|
||||
|
||||
(production :finally-clause (finally :block) finally-clause-block)
|
||||
|
||||
|
||||
(%subsection "Function Definition")
|
||||
(production :function-definition (:named-function) function-definition-named-function)
|
||||
|
||||
(production :anonymous-function (function :formal-parameters-and-body) anonymous-function-formal-parameters-and-body)
|
||||
|
||||
(production :named-function (function $identifier :formal-parameters-and-body) named-function-formal-parameters-and-body)
|
||||
|
||||
(production :formal-parameters-and-body (\( :formal-parameters \) { :top-statements }) formal-parameters-and-body)
|
||||
|
||||
(production :formal-parameters () formal-parameters-none)
|
||||
(production :formal-parameters (:formal-parameters-prefix) formal-parameters-some)
|
||||
|
||||
(production :formal-parameters-prefix (:formal-parameter) formal-parameters-prefix-one)
|
||||
(production :formal-parameters-prefix (:formal-parameters-prefix \, :formal-parameter) formal-parameters-prefix-more)
|
||||
|
||||
(production :formal-parameter ($identifier) formal-parameter-identifier)
|
||||
|
||||
|
||||
(%section "Programs")
|
||||
|
||||
(production :program (:top-statements) program)
|
||||
|
||||
(production :top-statements () top-statements-one)
|
||||
(production :top-statements (:top-statements-prefix) top-statements-more)
|
||||
|
||||
(production :top-statements-prefix (:top-statement) top-statements-prefix-one)
|
||||
(production :top-statements-prefix (:top-statements-prefix :top-statement) top-statements-prefix-more)
|
||||
|
||||
(production :top-statement ((:statement full)) top-statement-statement)
|
||||
(production :top-statement (:function-definition) top-statement-function-definition)
|
||||
)))
|
||||
|
||||
(defparameter *jg* (world-grammar *jw* 'code-grammar))
|
||||
(length (grammar-states *jg*)))
|
||||
|
||||
|
||||
#|
|
||||
(depict-rtf-to-local-file
|
||||
";JS14;ParserGrammar.rtf"
|
||||
"JavaScript 1.4 Parser Grammar"
|
||||
#'(lambda (markup-stream)
|
||||
(depict-world-commands markup-stream *jw* :visible-semantics nil)))
|
||||
|
||||
(depict-html-to-local-file
|
||||
";JS14;ParserGrammar.html"
|
||||
"JavaScript 1.4 Parser Grammar"
|
||||
t
|
||||
#'(lambda (markup-stream)
|
||||
(depict-world-commands markup-stream *jw* :visible-semantics nil)))
|
||||
|
||||
(with-local-output (s ";JS14;ParserGrammar.txt") (print-grammar *jg* s))
|
||||
|#
|
||||
|
|
@ -524,7 +524,7 @@
|
|||
|
||||
#|
|
||||
(depict-rtf-to-local-file
|
||||
";JS20;LexerCharClasses.rtf"
|
||||
"JS20/LexerCharClasses.rtf"
|
||||
"JavaScript 2 Lexer Character Classes"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-paragraph (rtf-stream ':grammar-header)
|
||||
|
|
@ -537,33 +537,33 @@
|
|||
|
||||
(progn
|
||||
(depict-rtf-to-local-file
|
||||
";JS20;LexerGrammar.rtf"
|
||||
"JS20/LexerGrammar.rtf"
|
||||
"JavaScript 2 Lexer Grammar"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *lw* :visible-semantics nil)))
|
||||
(depict-rtf-to-local-file
|
||||
";JS20;LexerSemantics.rtf"
|
||||
"JS20/LexerSemantics.rtf"
|
||||
"JavaScript 2 Lexer Semantics"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *lw*))))
|
||||
|
||||
(progn
|
||||
(depict-html-to-local-file
|
||||
";JS20;LexerGrammar.html"
|
||||
"JS20/LexerGrammar.html"
|
||||
"JavaScript 2 Lexer Grammar"
|
||||
t
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *lw* :visible-semantics nil))
|
||||
:external-link-base "notation.html")
|
||||
(depict-html-to-local-file
|
||||
";JS20;LexerSemantics.html"
|
||||
"JS20/LexerSemantics.html"
|
||||
"JavaScript 2 Lexer Semantics"
|
||||
t
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *lw*))
|
||||
:external-link-base "notation.html"))
|
||||
|
||||
(with-local-output (s ";JS20;LexerGrammar.txt") (print-lexer *ll* s) (print-grammar *lg* s))
|
||||
(with-local-output (s "JS20/LexerGrammar.txt") (print-lexer *ll* s) (print-grammar *lg* s))
|
||||
|
||||
(print-illegal-strings m)
|
||||
|#
|
||||
|
|
|
|||
|
|
@ -634,21 +634,21 @@
|
|||
|
||||
#|
|
||||
(depict-rtf-to-local-file
|
||||
";JS20;ParserGrammar.rtf"
|
||||
"JS20/ParserGrammar.rtf"
|
||||
"JavaScript 2.0 Parser Grammar"
|
||||
#'(lambda (markup-stream)
|
||||
(depict-js-terminals markup-stream *jg*)
|
||||
(depict-world-commands markup-stream *jw* :visible-semantics nil)))
|
||||
|
||||
(depict-html-to-local-file
|
||||
";JS20;ParserGrammar.html"
|
||||
"JS20/ParserGrammar.html"
|
||||
"JavaScript 2.0 Parser Grammar"
|
||||
t
|
||||
#'(lambda (markup-stream)
|
||||
(depict-js-terminals markup-stream *jg*)
|
||||
(depict-world-commands markup-stream *jw* :visible-semantics nil)))
|
||||
|
||||
(with-local-output (s ";JS20;ParserGrammar.txt") (print-grammar *jg* s))
|
||||
(with-local-output (s "JS20/ParserGrammar.txt") (print-grammar *jg* s))
|
||||
|#
|
||||
|
||||
(length (grammar-states *jg*))
|
||||
|
|
|
|||
|
|
@ -586,33 +586,33 @@
|
|||
#|
|
||||
(progn
|
||||
(depict-rtf-to-local-file
|
||||
";JS20;RegExpGrammar.rtf"
|
||||
"JS20/RegExpGrammar.rtf"
|
||||
"Regular Expression Grammar"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *rw* :visible-semantics nil)))
|
||||
(depict-rtf-to-local-file
|
||||
";JS20;RegExpSemantics.rtf"
|
||||
"JS20/RegExpSemantics.rtf"
|
||||
"Regular Expression Semantics"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *rw*))))
|
||||
|
||||
(progn
|
||||
(depict-html-to-local-file
|
||||
";JS20;RegExpGrammar.html"
|
||||
"JS20/RegExpGrammar.html"
|
||||
"Regular Expression Grammar"
|
||||
t
|
||||
#'(lambda (html-stream)
|
||||
(depict-world-commands html-stream *rw* :visible-semantics nil))
|
||||
:external-link-base "notation.html")
|
||||
(depict-html-to-local-file
|
||||
";JS20;RegExpSemantics.html"
|
||||
"JS20/RegExpSemantics.html"
|
||||
"Regular Expression Semantics"
|
||||
t
|
||||
#'(lambda (html-stream)
|
||||
(depict-world-commands html-stream *rw*))
|
||||
:external-link-base "notation.html"))
|
||||
|
||||
(with-local-output (s ";JS20;RegExpGrammar.txt") (print-lexer *rl* s) (print-grammar *rg* s))
|
||||
(with-local-output (s "JS20/RegExpGrammar.txt") (print-lexer *rl* s) (print-grammar *rg* s))
|
||||
|
||||
(lexer-pparse *rl* "a+" :trace t)
|
||||
(lexer-pparse *rl* "[]+" :trace t)
|
||||
|
|
|
|||
|
|
@ -1,492 +0,0 @@
|
|||
;;; The contents of this file are subject to the Mozilla Public
|
||||
;;; License Version 1.1 (the "License"); you may not use this file
|
||||
;;; except in compliance with the License. You may obtain a copy of
|
||||
;;; the License at http://www.mozilla.org/MPL/
|
||||
;;;
|
||||
;;; Software distributed under the License is distributed on an "AS
|
||||
;;; IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
|
||||
;;; implied. See the License for the specific language governing
|
||||
;;; rights and limitations under the License.
|
||||
;;;
|
||||
;;; The Original Code is the Language Design and Prototyping Environment.
|
||||
;;;
|
||||
;;; The Initial Developer of the Original Code is Netscape Communications
|
||||
;;; Corporation. Portions created by Netscape Communications Corporation are
|
||||
;;; Copyright (C) 1999 Netscape Communications Corporation. All
|
||||
;;; Rights Reserved.
|
||||
;;;
|
||||
;;; Contributor(s): Waldemar Horwat <waldemar@acm.org>
|
||||
|
||||
;;;
|
||||
;;; ECMAScript sample lexer
|
||||
;;;
|
||||
;;; Waldemar Horwat (waldemar@acm.org)
|
||||
;;;
|
||||
|
||||
(progn
|
||||
(defparameter *lw*
|
||||
(generate-world
|
||||
"L"
|
||||
'((lexer code-lexer
|
||||
:lalr-1
|
||||
:next-token
|
||||
((:unicode-character (% every (:text "Any Unicode character")) () t)
|
||||
(:white-space-character (#?0009 #?000B #?000C #\space) ())
|
||||
(:line-terminator (#?000A #?000D) ())
|
||||
(:non-terminator (- :unicode-character :line-terminator) ())
|
||||
(:non-terminator-or-slash (- :non-terminator (#\/)) ())
|
||||
(:non-terminator-or-asterisk-or-slash (- :non-terminator (#\* #\/)) ())
|
||||
(:identifier-letter (++ (#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)
|
||||
(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z)
|
||||
(#\$ #\_))
|
||||
((character-value character-value)))
|
||||
(:decimal-digit (#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
|
||||
((character-value character-value)
|
||||
(decimal-value $digit-value)))
|
||||
(:non-zero-digit (#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
|
||||
((decimal-value $digit-value)))
|
||||
(:octal-digit (#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7)
|
||||
((character-value character-value)
|
||||
(octal-value $digit-value)))
|
||||
(:zero-to-three (#\0 #\1 #\2 #\3)
|
||||
((octal-value $digit-value)))
|
||||
(:four-to-seven (#\4 #\5 #\6 #\7)
|
||||
((octal-value $digit-value)))
|
||||
(:hex-digit (#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\A #\B #\C #\D #\E #\F #\a #\b #\c #\d #\e #\f)
|
||||
((hex-value $digit-value)))
|
||||
(:exponent-indicator (#\E #\e) ())
|
||||
(:hex-indicator (#\X #\x) ())
|
||||
(:plain-string-char (- :unicode-character (+ (#\' #\" #\\) :octal-digit :line-terminator))
|
||||
((character-value character-value)))
|
||||
(:string-non-escape (- :non-terminator (+ :octal-digit (#\x #\u #\' #\" #\\ #\b #\f #\n #\r #\t #\v)))
|
||||
((character-value character-value))))
|
||||
((character-value character nil identity)
|
||||
($digit-value integer digit-value digit-char-36)))
|
||||
|
||||
(%section "Comments")
|
||||
(production :line-comment (#\/ #\/ :line-comment-characters) line-comment)
|
||||
|
||||
(production :line-comment-characters () line-comment-characters-empty)
|
||||
(production :line-comment-characters (:line-comment-characters :non-terminator) line-comment-characters-chars)
|
||||
(%charclass :unicode-character)
|
||||
(%charclass :non-terminator)
|
||||
|
||||
(production :single-line-block-comment (#\/ #\* :block-comment-characters #\* #\/) single-line-block-comment)
|
||||
|
||||
(production :block-comment-characters () block-comment-characters-empty)
|
||||
(production :block-comment-characters (:block-comment-characters :non-terminator-or-slash) block-comment-characters-chars)
|
||||
(production :block-comment-characters (:pre-slash-characters #\/) block-comment-characters-slash)
|
||||
|
||||
(production :pre-slash-characters () pre-slash-characters-empty)
|
||||
(production :pre-slash-characters (:block-comment-characters :non-terminator-or-asterisk-or-slash) pre-slash-characters-chars)
|
||||
(production :pre-slash-characters (:pre-slash-characters #\/) pre-slash-characters-slash)
|
||||
|
||||
(%charclass :non-terminator-or-slash)
|
||||
(%charclass :non-terminator-or-asterisk-or-slash)
|
||||
|
||||
(production :multi-line-block-comment (#\/ #\* :multi-line-block-comment-characters :block-comment-characters #\* #\/) multi-line-block-comment)
|
||||
|
||||
(production :multi-line-block-comment-characters (:block-comment-characters :line-terminator) multi-line-block-comment-characters-first)
|
||||
(production :multi-line-block-comment-characters (:multi-line-block-comment-characters :block-comment-characters :line-terminator)
|
||||
multi-line-block-comment-characters-rest)
|
||||
|
||||
(%section "White space")
|
||||
|
||||
(production :white-space () white-space-empty)
|
||||
(production :white-space (:white-space :white-space-character) white-space-character)
|
||||
(production :white-space (:white-space :single-line-block-comment) white-space-single-line-block-comment)
|
||||
(%charclass :white-space-character)
|
||||
|
||||
(%section "Line breaks")
|
||||
|
||||
(production :line-break (:line-terminator) line-break-line-terminator)
|
||||
(production :line-break (:line-comment :line-terminator) line-break-line-comment)
|
||||
(production :line-break (:multi-line-block-comment) line-break-multi-line-block-comment)
|
||||
(%charclass :line-terminator)
|
||||
|
||||
(production :line-breaks (:line-break) line-breaks-first)
|
||||
(production :line-breaks (:line-breaks :white-space :line-break) line-breaks-rest)
|
||||
|
||||
(%section "Tokens")
|
||||
|
||||
(declare-action token :next-token token)
|
||||
(production :next-token (:white-space :token) next-token
|
||||
(token (token :token)))
|
||||
|
||||
(declare-action token :token token)
|
||||
(production :token (:line-breaks) token-line-breaks
|
||||
(token (oneof line-breaks)))
|
||||
(production :token (:identifier-or-reserved-word) token-identifier-or-reserved-word
|
||||
(token (token :identifier-or-reserved-word)))
|
||||
(production :token (:punctuator) token-punctuator
|
||||
(token (oneof punctuator (punctuator :punctuator))))
|
||||
(production :token (:numeric-literal) token-numeric-literal
|
||||
(token (oneof number (double-value :numeric-literal))))
|
||||
(production :token (:string-literal) token-string-literal
|
||||
(token (oneof string (string-value :string-literal))))
|
||||
(production :token (:end-of-input) token-end
|
||||
(token (oneof end)))
|
||||
|
||||
(production :end-of-input ($end) end-of-input-end)
|
||||
(production :end-of-input (:line-comment $end) end-of-input-line-comment)
|
||||
|
||||
(deftype token (oneof (identifier string) (reserved-word string) (punctuator string) (number double) (string string) line-breaks end))
|
||||
(%print-actions)
|
||||
|
||||
(%section "Keywords")
|
||||
|
||||
(declare-action name :identifier-name string)
|
||||
(production :identifier-name (:identifier-letter) identifier-name-letter
|
||||
(name (vector (character-value :identifier-letter))))
|
||||
(production :identifier-name (:identifier-name :identifier-letter) identifier-name-next-letter
|
||||
(name (append (name :identifier-name) (vector (character-value :identifier-letter)))))
|
||||
(production :identifier-name (:identifier-name :decimal-digit) identifier-name-next-digit
|
||||
(name (append (name :identifier-name) (vector (character-value :decimal-digit)))))
|
||||
(%charclass :identifier-letter)
|
||||
(%charclass :decimal-digit)
|
||||
(%print-actions)
|
||||
|
||||
(define keywords (vector string)
|
||||
(vector "break" "case" "catch" "continue" "default" "delete" "do" "else" "finally" "for" "function" "if" "in"
|
||||
"new" "return" "switch" "this" "throw" "try" "typeof" "var" "void" "while" "with"))
|
||||
(define future-reserved-words (vector string)
|
||||
(vector "class" "const" "debugger" "enum" "export" "extends" "import" "super"))
|
||||
(define literals (vector string)
|
||||
(vector "null" "true" "false"))
|
||||
(define reserved-words (vector string)
|
||||
(append keywords (append future-reserved-words literals)))
|
||||
|
||||
(define (member (id string) (list (vector string))) boolean
|
||||
(if (empty list)
|
||||
false
|
||||
(let ((s string (nth list 0)))
|
||||
(if (string-equal id s)
|
||||
true
|
||||
(member id (subseq list 1))))))
|
||||
|
||||
(declare-action token :identifier-or-reserved-word token)
|
||||
(production :identifier-or-reserved-word (:identifier-name) identifier-or-reserved-word-identifier-name
|
||||
(token (let ((id string (name :identifier-name)))
|
||||
(if (member id reserved-words)
|
||||
(oneof reserved-word id)
|
||||
(oneof identifier id)))))
|
||||
(%print-actions)
|
||||
|
||||
(%section "Punctuators")
|
||||
|
||||
(declare-action punctuator :punctuator string)
|
||||
(production :punctuator (#\=) punctuator-assignment (punctuator "="))
|
||||
(production :punctuator (#\>) punctuator-greater-than (punctuator ">"))
|
||||
(production :punctuator (#\<) punctuator-less-than (punctuator "<"))
|
||||
(production :punctuator (#\= #\=) punctuator-equal (punctuator "=="))
|
||||
(production :punctuator (#\= #\= #\=) punctuator-identical (punctuator "==="))
|
||||
(production :punctuator (#\< #\=) punctuator-less-than-or-equal (punctuator "<="))
|
||||
(production :punctuator (#\> #\=) punctuator-greater-than-or-equal (punctuator ">="))
|
||||
(production :punctuator (#\! #\=) punctuator-not-equal (punctuator "!="))
|
||||
(production :punctuator (#\! #\= #\=) punctuator-not-identical (punctuator "!=="))
|
||||
(production :punctuator (#\,) punctuator-comma (punctuator ","))
|
||||
(production :punctuator (#\!) punctuator-not (punctuator "!"))
|
||||
(production :punctuator (#\~) punctuator-complement (punctuator "~"))
|
||||
(production :punctuator (#\?) punctuator-question (punctuator "?"))
|
||||
(production :punctuator (#\:) punctuator-colon (punctuator ":"))
|
||||
(production :punctuator (#\.) punctuator-period (punctuator "."))
|
||||
(production :punctuator (#\& #\&) punctuator-logical-and (punctuator "&&"))
|
||||
(production :punctuator (#\| #\|) punctuator-logical-or (punctuator "||"))
|
||||
(production :punctuator (#\+ #\+) punctuator-increment (punctuator "++"))
|
||||
(production :punctuator (#\- #\-) punctuator-decrement (punctuator "--"))
|
||||
(production :punctuator (#\+) punctuator-plus (punctuator "+"))
|
||||
(production :punctuator (#\-) punctuator-minus (punctuator "-"))
|
||||
(production :punctuator (#\*) punctuator-times (punctuator "*"))
|
||||
(production :punctuator (#\/) punctuator-divide (punctuator "/"))
|
||||
(production :punctuator (#\&) punctuator-and (punctuator "&"))
|
||||
(production :punctuator (#\|) punctuator-or (punctuator "|"))
|
||||
(production :punctuator (#\^) punctuator-xor (punctuator "^"))
|
||||
(production :punctuator (#\%) punctuator-modulo (punctuator "%"))
|
||||
(production :punctuator (#\< #\<) punctuator-left-shift (punctuator "<<"))
|
||||
(production :punctuator (#\> #\>) punctuator-right-shift (punctuator ">>"))
|
||||
(production :punctuator (#\> #\> #\>) punctuator-logical-right-shift (punctuator ">>>"))
|
||||
(production :punctuator (#\+ #\=) punctuator-plus-equals (punctuator "+="))
|
||||
(production :punctuator (#\- #\=) punctuator-minus-equals (punctuator "-="))
|
||||
(production :punctuator (#\* #\=) punctuator-times-equals (punctuator "*="))
|
||||
(production :punctuator (#\/ #\=) punctuator-divide-equals (punctuator "/="))
|
||||
(production :punctuator (#\& #\=) punctuator-and-equals (punctuator "&="))
|
||||
(production :punctuator (#\| #\=) punctuator-or-equals (punctuator "|="))
|
||||
(production :punctuator (#\^ #\=) punctuator-xor-equals (punctuator "^="))
|
||||
(production :punctuator (#\% #\=) punctuator-modulo-equals (punctuator "%="))
|
||||
(production :punctuator (#\< #\< #\=) punctuator-left-shift-equals (punctuator "<<="))
|
||||
(production :punctuator (#\> #\> #\=) punctuator-right-shift-equals (punctuator ">>="))
|
||||
(production :punctuator (#\> #\> #\> #\=) punctuator-logical-right-shift-equals (punctuator ">>>="))
|
||||
(production :punctuator (#\() punctuator-open-parenthesis (punctuator "("))
|
||||
(production :punctuator (#\)) punctuator-close-parenthesis (punctuator ")"))
|
||||
(production :punctuator (#\{) punctuator-open-brace (punctuator "{"))
|
||||
(production :punctuator (#\}) punctuator-close-brace (punctuator "}"))
|
||||
(production :punctuator (#\[) punctuator-open-bracket (punctuator "["))
|
||||
(production :punctuator (#\]) punctuator-close-bracket (punctuator "]"))
|
||||
(production :punctuator (#\;) punctuator-semicolon (punctuator ";"))
|
||||
(%print-actions)
|
||||
|
||||
(%section "Numeric literals")
|
||||
|
||||
(declare-action double-value :numeric-literal double)
|
||||
(production :numeric-literal (:decimal-literal) numeric-literal-decimal
|
||||
(double-value (rational-to-double (rational-value :decimal-literal))))
|
||||
(production :numeric-literal (:hex-integer-literal) numeric-literal-hex
|
||||
(double-value (rational-to-double (integer-value :hex-integer-literal))))
|
||||
(production :numeric-literal (:octal-integer-literal) numeric-literal-octal
|
||||
(double-value (rational-to-double (integer-value :octal-integer-literal))))
|
||||
(%print-actions)
|
||||
|
||||
(define (expt (base rational) (exponent integer)) rational
|
||||
(if (= exponent 0)
|
||||
1
|
||||
(if (< exponent 0)
|
||||
(rational/ 1 (expt base (neg exponent)))
|
||||
(rational* base (expt base (- exponent 1))))))
|
||||
|
||||
(declare-action rational-value :decimal-literal rational)
|
||||
(production :decimal-literal (:mantissa :exponent) decimal-literal
|
||||
(rational-value (rational* (rational-value :mantissa) (expt 10 (integer-value :exponent)))))
|
||||
|
||||
(declare-action rational-value :mantissa rational)
|
||||
(production :mantissa (:decimal-integer-literal) mantissa-integer
|
||||
(rational-value (integer-value :decimal-integer-literal)))
|
||||
(production :mantissa (:decimal-integer-literal #\.) mantissa-integer-dot
|
||||
(rational-value (integer-value :decimal-integer-literal)))
|
||||
(production :mantissa (:decimal-integer-literal #\. :fraction) mantissa-integer-dot-fraction
|
||||
(rational-value (rational+ (integer-value :decimal-integer-literal)
|
||||
(rational-value :fraction))))
|
||||
(production :mantissa (#\. :fraction) mantissa-dot-fraction
|
||||
(rational-value (rational-value :fraction)))
|
||||
|
||||
(declare-action integer-value :decimal-integer-literal integer)
|
||||
(production :decimal-integer-literal (#\0) decimal-integer-literal-0
|
||||
(integer-value 0))
|
||||
(production :decimal-integer-literal (:non-zero-decimal-digits) decimal-integer-literal-nonzero
|
||||
(integer-value (integer-value :non-zero-decimal-digits)))
|
||||
|
||||
(declare-action integer-value :non-zero-decimal-digits integer)
|
||||
(production :non-zero-decimal-digits (:non-zero-digit) non-zero-decimal-digits-first
|
||||
(integer-value (decimal-value :non-zero-digit)))
|
||||
(production :non-zero-decimal-digits (:non-zero-decimal-digits :decimal-digit) non-zero-decimal-digits-rest
|
||||
(integer-value (+ (* 10 (integer-value :non-zero-decimal-digits)) (decimal-value :decimal-digit))))
|
||||
|
||||
(%charclass :non-zero-digit)
|
||||
|
||||
(declare-action rational-value :fraction rational)
|
||||
(production :fraction (:decimal-digits) fraction-decimal-digits
|
||||
(rational-value (rational/ (integer-value :decimal-digits)
|
||||
(expt 10 (n-digits :decimal-digits)))))
|
||||
(%print-actions)
|
||||
|
||||
(declare-action integer-value :exponent integer)
|
||||
(production :exponent () exponent-none
|
||||
(integer-value 0))
|
||||
(production :exponent (:exponent-indicator :signed-integer) exponent-integer
|
||||
(integer-value (integer-value :signed-integer)))
|
||||
(%charclass :exponent-indicator)
|
||||
|
||||
(declare-action integer-value :signed-integer integer)
|
||||
(production :signed-integer (:decimal-digits) signed-integer-no-sign
|
||||
(integer-value (integer-value :decimal-digits)))
|
||||
(production :signed-integer (#\+ :decimal-digits) signed-integer-plus
|
||||
(integer-value (integer-value :decimal-digits)))
|
||||
(production :signed-integer (#\- :decimal-digits) signed-integer-minus
|
||||
(integer-value (neg (integer-value :decimal-digits))))
|
||||
(%print-actions)
|
||||
|
||||
(declare-action integer-value :decimal-digits integer)
|
||||
(declare-action n-digits :decimal-digits integer)
|
||||
(production :decimal-digits (:decimal-digit) decimal-digits-first
|
||||
(integer-value (decimal-value :decimal-digit))
|
||||
(n-digits 1))
|
||||
(production :decimal-digits (:decimal-digits :decimal-digit) decimal-digits-rest
|
||||
(integer-value (+ (* 10 (integer-value :decimal-digits)) (decimal-value :decimal-digit)))
|
||||
(n-digits (+ (n-digits :decimal-digits) 1)))
|
||||
(%print-actions)
|
||||
|
||||
(declare-action integer-value :hex-integer-literal integer)
|
||||
(production :hex-integer-literal (#\0 :hex-indicator :hex-digit) hex-integer-literal-first
|
||||
(integer-value (hex-value :hex-digit)))
|
||||
(production :hex-integer-literal (:hex-integer-literal :hex-digit) hex-integer-literal-rest
|
||||
(integer-value (+ (* 16 (integer-value :hex-integer-literal)) (hex-value :hex-digit))))
|
||||
(%charclass :hex-indicator)
|
||||
(%charclass :hex-digit)
|
||||
|
||||
(declare-action integer-value :octal-integer-literal integer)
|
||||
(production :octal-integer-literal (#\0 :octal-digit) octal-integer-literal-first
|
||||
(integer-value (octal-value :octal-digit)))
|
||||
(production :octal-integer-literal (:octal-integer-literal :octal-digit) octal-integer-literal-rest
|
||||
(integer-value (+ (* 8 (integer-value :octal-integer-literal)) (octal-value :octal-digit))))
|
||||
(%charclass :octal-digit)
|
||||
(%print-actions)
|
||||
|
||||
(%section "String literals")
|
||||
|
||||
(grammar-argument :quote single double)
|
||||
(declare-action string-value :string-literal string)
|
||||
(production :string-literal (#\' (:string-chars single) #\') string-literal-single
|
||||
(string-value (string-value :string-chars)))
|
||||
(production :string-literal (#\" (:string-chars double) #\") string-literal-double
|
||||
(string-value (string-value :string-chars)))
|
||||
(%print-actions)
|
||||
|
||||
(declare-action string-value (:string-chars :quote) string)
|
||||
(production (:string-chars :quote) ((:ordinary-string-chars :quote)) string-chars-ordinary
|
||||
(string-value (string-value :ordinary-string-chars)))
|
||||
(production (:string-chars :quote) ((:string-chars :quote) #\\ :short-octal-escape) string-chars-short-escape
|
||||
(string-value (append (string-value :string-chars)
|
||||
(vector (character-value :short-octal-escape)))))
|
||||
|
||||
(declare-action string-value (:ordinary-string-chars :quote) string)
|
||||
(production (:ordinary-string-chars :quote) () ordinary-string-chars-empty
|
||||
(string-value ""))
|
||||
(production (:ordinary-string-chars :quote) ((:string-chars :quote) :plain-string-char) ordinary-string-chars-char
|
||||
(string-value (append (string-value :string-chars)
|
||||
(vector (character-value :plain-string-char)))))
|
||||
(production (:ordinary-string-chars :quote) ((:string-chars :quote) (:plain-string-quote :quote)) ordinary-string-chars-quote
|
||||
(string-value (append (string-value :string-chars)
|
||||
(vector (character-value :plain-string-quote)))))
|
||||
(production (:ordinary-string-chars :quote) ((:ordinary-string-chars :quote) :octal-digit) ordinary-string-chars-octal
|
||||
(string-value (append (string-value :ordinary-string-chars)
|
||||
(vector (character-value :octal-digit)))))
|
||||
(production (:ordinary-string-chars :quote) ((:string-chars :quote) #\\ :ordinary-escape) ordinary-string-chars-escape
|
||||
(string-value (append (string-value :string-chars)
|
||||
(vector (character-value :ordinary-escape)))))
|
||||
|
||||
(%charclass :plain-string-char)
|
||||
|
||||
(declare-action character-value (:plain-string-quote :quote) character)
|
||||
(production (:plain-string-quote single) (#\") plain-string-quote-single
|
||||
(character-value #\"))
|
||||
(production (:plain-string-quote double) (#\') plain-string-quote-double
|
||||
(character-value #\'))
|
||||
(%print-actions)
|
||||
|
||||
(declare-action character-value :ordinary-escape character)
|
||||
(production :ordinary-escape (:string-char-escape) ordinary-escape-character
|
||||
(character-value (character-value :string-char-escape)))
|
||||
(production :ordinary-escape (:full-octal-escape) ordinary-escape-full-octal
|
||||
(character-value (character-value :full-octal-escape)))
|
||||
(production :ordinary-escape (:hex-escape) ordinary-escape-hex
|
||||
(character-value (character-value :hex-escape)))
|
||||
(production :ordinary-escape (:unicode-escape) ordinary-escape-unicode
|
||||
(character-value (character-value :unicode-escape)))
|
||||
(production :ordinary-escape (:string-non-escape) ordinary-escape-non-escape
|
||||
(character-value (character-value :string-non-escape)))
|
||||
(%charclass :string-non-escape)
|
||||
(%print-actions)
|
||||
|
||||
(declare-action character-value :string-char-escape character)
|
||||
(production :string-char-escape (#\') string-char-escape-single-quote (character-value #\'))
|
||||
(production :string-char-escape (#\") string-char-escape-double-quote (character-value #\"))
|
||||
(production :string-char-escape (#\\) string-char-escape-backslash (character-value #\\))
|
||||
(production :string-char-escape (#\b) string-char-escape-backspace (character-value #?0008))
|
||||
(production :string-char-escape (#\f) string-char-escape-form-feed (character-value #?000C))
|
||||
(production :string-char-escape (#\n) string-char-escape-new-line (character-value #?000A))
|
||||
(production :string-char-escape (#\r) string-char-escape-return (character-value #?000D))
|
||||
(production :string-char-escape (#\t) string-char-escape-tab (character-value #?0009))
|
||||
(production :string-char-escape (#\v) string-char-escape-vertical-tab (character-value #?000B))
|
||||
(%print-actions)
|
||||
|
||||
(declare-action character-value :short-octal-escape character)
|
||||
(production :short-octal-escape (:octal-digit) short-octal-escape-1
|
||||
(character-value (code-to-character (octal-value :octal-digit))))
|
||||
(production :short-octal-escape (:zero-to-three :octal-digit) short-octal-escape-2
|
||||
(character-value (code-to-character (+ (* 8 (octal-value :zero-to-three))
|
||||
(octal-value :octal-digit)))))
|
||||
|
||||
(declare-action character-value :full-octal-escape character)
|
||||
(production :full-octal-escape (:four-to-seven :octal-digit) full-octal-escape-2
|
||||
(character-value (code-to-character (+ (* 8 (octal-value :four-to-seven))
|
||||
(octal-value :octal-digit)))))
|
||||
(production :full-octal-escape (:zero-to-three :octal-digit :octal-digit) full-octal-escape-3
|
||||
(character-value (code-to-character (+ (+ (* 64 (octal-value :zero-to-three))
|
||||
(* 8 (octal-value :octal-digit 1)))
|
||||
(octal-value :octal-digit 2)))))
|
||||
(%charclass :zero-to-three)
|
||||
(%charclass :four-to-seven)
|
||||
|
||||
(declare-action character-value :hex-escape character)
|
||||
(production :hex-escape (#\x :hex-digit :hex-digit) hex-escape-2
|
||||
(character-value (code-to-character (+ (* 16 (hex-value :hex-digit 1))
|
||||
(hex-value :hex-digit 2)))))
|
||||
|
||||
(declare-action character-value :unicode-escape character)
|
||||
(production :unicode-escape (#\u :hex-digit :hex-digit :hex-digit :hex-digit) unicode-escape-4
|
||||
(character-value (code-to-character (+ (+ (+ (* 4096 (hex-value :hex-digit 1))
|
||||
(* 256 (hex-value :hex-digit 2)))
|
||||
(* 16 (hex-value :hex-digit 3)))
|
||||
(hex-value :hex-digit 4)))))
|
||||
(%print-actions)
|
||||
|
||||
)))
|
||||
|
||||
(defparameter *ll* (world-lexer *lw* 'code-lexer))
|
||||
(defparameter *lg* (lexer-grammar *ll*))
|
||||
(set-up-lexer-metagrammar *ll*)
|
||||
(defparameter *lm* (lexer-metagrammar *ll*)))
|
||||
|
||||
#|
|
||||
(depict-rtf-to-local-file
|
||||
";JSECMA;LexerCharClasses.rtf"
|
||||
"ECMAScript 1 Lexer Character Classes"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-paragraph (rtf-stream ':grammar-header)
|
||||
(depict rtf-stream "Character Classes"))
|
||||
(dolist (charclass (lexer-charclasses *ll*))
|
||||
(depict-charclass rtf-stream charclass))
|
||||
(depict-paragraph (rtf-stream ':grammar-header)
|
||||
(depict rtf-stream "Grammar"))
|
||||
(depict-grammar rtf-stream *lg*)))
|
||||
|
||||
(depict-rtf-to-local-file
|
||||
";JSECMA;LexerSemantics.rtf"
|
||||
"ECMAScript 1 Lexer Semantics"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *lw*)))
|
||||
|
||||
(depict-html-to-local-file
|
||||
";JSECMA;LexerSemantics.html"
|
||||
"ECMAScript 1 Lexer Semantics"
|
||||
t
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *lw*)))
|
||||
|
||||
(with-local-output (s ";JSECMA;LexerGrammar.txt") (print-lexer *ll* s) (print-grammar *lg* s))
|
||||
|
||||
(print-illegal-strings m)
|
||||
|
||||
(lexer-pparse *ll* "0x20")
|
||||
(lexer-pparse *ll* "2b")
|
||||
(lexer-pparse *ll* " 3.75" :trace t)
|
||||
(lexer-pparse *ll* "25" :trace :code)
|
||||
(lexer-pmetaparse *ll* "32+abc//23e-a4*7e-2 3 id4 4ef;")
|
||||
(lexer-pmetaparse *ll* "32+abc//23e-a4*7e-2 3 id4 4ef;
|
||||
")
|
||||
(lexer-pmetaparse *ll* "32+abc/ /23e-a4*7e-2 3 /*id4 4*-/ef;
|
||||
|
||||
fjds*/y//z")
|
||||
(lexer-pmetaparse *ll* "3a+in'a+b\\147\"de'\"'\"")
|
||||
|#
|
||||
|
||||
|
||||
; Return the ECMAScript input string as a list of tokens like:
|
||||
; (($number . 3.0) + - ++ else ($string . "a+bgde") ($end))
|
||||
; Line breaks are removed.
|
||||
(defun tokenize (string)
|
||||
(delete
|
||||
'($line-breaks)
|
||||
(mapcar
|
||||
#'(lambda (token-value)
|
||||
(let ((token-value (car token-value)))
|
||||
(ecase (car token-value)
|
||||
(identifier (cons '$identifier (cdr token-value)))
|
||||
((reserved-word punctuator) (intern (string-upcase (cdr token-value))))
|
||||
(number (cons '$number (cdr token-value)))
|
||||
(string (cons '$string (cdr token-value)))
|
||||
(line-breaks '($line-breaks))
|
||||
(end '($end)))))
|
||||
(lexer-metaparse *ll* string))
|
||||
:test #'equal))
|
||||
|
||||
|
||||
|
|
@ -1,858 +0,0 @@
|
|||
;;; The contents of this file are subject to the Mozilla Public
|
||||
;;; License Version 1.1 (the "License"); you may not use this file
|
||||
;;; except in compliance with the License. You may obtain a copy of
|
||||
;;; the License at http://www.mozilla.org/MPL/
|
||||
;;;
|
||||
;;; Software distributed under the License is distributed on an "AS
|
||||
;;; IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
|
||||
;;; implied. See the License for the specific language governing
|
||||
;;; rights and limitations under the License.
|
||||
;;;
|
||||
;;; The Original Code is the Language Design and Prototyping Environment.
|
||||
;;;
|
||||
;;; The Initial Developer of the Original Code is Netscape Communications
|
||||
;;; Corporation. Portions created by Netscape Communications Corporation are
|
||||
;;; Copyright (C) 1999 Netscape Communications Corporation. All
|
||||
;;; Rights Reserved.
|
||||
;;;
|
||||
;;; Contributor(s): Waldemar Horwat <waldemar@acm.org>
|
||||
|
||||
;;;
|
||||
;;; ECMAScript sample grammar portions
|
||||
;;;
|
||||
;;; Waldemar Horwat (waldemar@acm.org)
|
||||
;;;
|
||||
|
||||
(declaim (optimize (debug 3)))
|
||||
|
||||
(progn
|
||||
(defparameter *gw*
|
||||
(generate-world
|
||||
"G"
|
||||
'((grammar code-grammar :lr-1 :program)
|
||||
|
||||
(%section "Types")
|
||||
|
||||
(deftype value (oneof undefined-value
|
||||
null-value
|
||||
(boolean-value boolean)
|
||||
(double-value double)
|
||||
(string-value string)
|
||||
(object-value object)))
|
||||
(deftype object-or-null (oneof null-object-or-null (object-object-or-null object)))
|
||||
(deftype object (tuple (properties (address (vector property)))
|
||||
(typeof-name string)
|
||||
(prototype object-or-null)
|
||||
(get (-> (prop-name) value-or-exception))
|
||||
(put (-> (prop-name value) void-or-exception))
|
||||
(delete (-> (prop-name) boolean-or-exception))
|
||||
(call (-> (object-or-null (vector value)) reference-or-exception))
|
||||
(construct (-> ((vector value)) object-or-exception))
|
||||
(default-value (-> (default-value-hint) value-or-exception))))
|
||||
(deftype default-value-hint (oneof no-hint number-hint string-hint))
|
||||
(deftype property (tuple (name string) (read-only boolean) (enumerable boolean) (permanent boolean) (value (address value))))
|
||||
|
||||
(deftype prop-name string)
|
||||
(deftype place (tuple (base object) (property prop-name)))
|
||||
(deftype reference (oneof (value-reference value) (place-reference place) (virtual-reference prop-name)))
|
||||
|
||||
|
||||
(deftype integer-or-exception (oneof (normal integer) (abrupt exception)))
|
||||
(deftype void-or-exception (oneof normal (abrupt exception)))
|
||||
(deftype boolean-or-exception (oneof (normal boolean) (abrupt exception)))
|
||||
(deftype double-or-exception (oneof (normal double) (abrupt exception)))
|
||||
(deftype string-or-exception (oneof (normal string) (abrupt exception)))
|
||||
(deftype object-or-exception (oneof (normal object) (abrupt exception)))
|
||||
(deftype value-or-exception (oneof (normal value) (abrupt exception)))
|
||||
(deftype reference-or-exception (oneof (normal reference) (abrupt exception)))
|
||||
(deftype value-list-or-exception (oneof (normal (vector value)) (abrupt exception)))
|
||||
|
||||
(%section "Helper Functions")
|
||||
|
||||
(define (object-or-null-to-value (o object-or-null)) value
|
||||
(case o
|
||||
(null-object-or-null (oneof null-value))
|
||||
((object-object-or-null obj object) (oneof object-value obj))))
|
||||
|
||||
(define undefined-result value-or-exception
|
||||
(oneof normal (oneof undefined-value)))
|
||||
(define null-result value-or-exception
|
||||
(oneof normal (oneof null-value)))
|
||||
(define (boolean-result (b boolean)) value-or-exception
|
||||
(oneof normal (oneof boolean-value b)))
|
||||
(define (double-result (d double)) value-or-exception
|
||||
(oneof normal (oneof double-value d)))
|
||||
(define (integer-result (i integer)) value-or-exception
|
||||
(double-result (rational-to-double i)))
|
||||
(define (string-result (s string)) value-or-exception
|
||||
(oneof normal (oneof string-value s)))
|
||||
(define (object-result (o object)) value-or-exception
|
||||
(oneof normal (oneof object-value o)))
|
||||
|
||||
(%section "Exceptions")
|
||||
|
||||
(deftype exception (oneof (exception value) (error error)))
|
||||
(deftype error (oneof coerce-to-primitive-error
|
||||
coerce-to-object-error
|
||||
get-value-error
|
||||
put-value-error
|
||||
delete-error))
|
||||
|
||||
(define (make-error (err error)) exception
|
||||
(oneof error err))
|
||||
|
||||
(%section "Objects")
|
||||
|
||||
|
||||
(%section "Conversions")
|
||||
|
||||
(define (reference-get-value (rv reference)) value-or-exception
|
||||
(case rv
|
||||
((value-reference v value) (oneof normal v))
|
||||
((place-reference r place) ((& get (& base r)) (& property r)))
|
||||
(virtual-reference (typed-oneof value-or-exception abrupt (make-error (oneof get-value-error))))))
|
||||
|
||||
(define (reference-put-value (rv reference) (v value)) void-or-exception
|
||||
(case rv
|
||||
(value-reference (typed-oneof void-or-exception abrupt (make-error (oneof put-value-error))))
|
||||
((place-reference r place) ((& put (& base r)) (& property r) v))
|
||||
(virtual-reference (bottom))))
|
||||
|
||||
(%section "Coercions")
|
||||
|
||||
(define (coerce-to-boolean (v value)) boolean
|
||||
(case v
|
||||
(((undefined-value null-value)) false)
|
||||
((boolean-value b boolean) b)
|
||||
((double-value d double) (not (or (double-is-zero d) (double-is-nan d))))
|
||||
((string-value s string) (/= (length s) 0))
|
||||
(object-value true)))
|
||||
|
||||
(define (coerce-boolean-to-double (b boolean)) double
|
||||
(if b 1.0 0.0))
|
||||
|
||||
(define (coerce-to-double (v value)) double-or-exception
|
||||
(case v
|
||||
(undefined-value (oneof normal nan))
|
||||
(null-value (oneof normal 0.0))
|
||||
((boolean-value b boolean) (oneof normal (coerce-boolean-to-double b)))
|
||||
((double-value d double) (oneof normal d))
|
||||
(string-value (bottom))
|
||||
(object-value (bottom))))
|
||||
|
||||
(define (coerce-to-uint32 (v value)) integer-or-exception
|
||||
(letexc (d double (coerce-to-double v))
|
||||
(oneof normal (double-to-uint32 d))))
|
||||
|
||||
(define (coerce-to-int32 (v value)) integer-or-exception
|
||||
(letexc (d double (coerce-to-double v))
|
||||
(oneof normal (uint32-to-int32 (double-to-uint32 d)))))
|
||||
|
||||
(define (uint32-to-int32 (ui integer)) integer
|
||||
(if (< ui #x80000000)
|
||||
ui
|
||||
(- ui #x100000000)))
|
||||
|
||||
(define (coerce-to-string (v value)) string-or-exception
|
||||
(case v
|
||||
(undefined-value (oneof normal "undefined"))
|
||||
(null-value (oneof normal "null"))
|
||||
((boolean-value b boolean) (if b (oneof normal "true") (oneof normal "false")))
|
||||
(double-value (bottom))
|
||||
((string-value s string) (oneof normal s))
|
||||
(object-value (bottom))))
|
||||
|
||||
(define (coerce-to-primitive (v value) (hint default-value-hint)) value-or-exception
|
||||
(case v
|
||||
(((undefined-value null-value boolean-value double-value string-value)) (oneof normal v))
|
||||
((object-value o object)
|
||||
(letexc (pv value ((& default-value o) hint))
|
||||
(case pv
|
||||
(((undefined-value null-value boolean-value double-value string-value)) (oneof normal pv))
|
||||
(object-value (typed-oneof value-or-exception abrupt (make-error (oneof coerce-to-primitive-error)))))))))
|
||||
|
||||
(define (coerce-to-object (v value)) object-or-exception
|
||||
(case v
|
||||
(((undefined-value null-value)) (typed-oneof object-or-exception abrupt (make-error (oneof coerce-to-object-error))))
|
||||
(boolean-value (bottom))
|
||||
(double-value (bottom))
|
||||
(string-value (bottom))
|
||||
((object-value o object) (oneof normal o))))
|
||||
|
||||
(%section "Environments")
|
||||
|
||||
(deftype env (tuple (this object-or-null)))
|
||||
(define (lookup-identifier (e env :unused) (id string :unused)) reference-or-exception
|
||||
(bottom))
|
||||
|
||||
(%section "Terminal Actions")
|
||||
|
||||
(declare-action eval-identifier $identifier string)
|
||||
(declare-action eval-number $number double)
|
||||
(declare-action eval-string $string string)
|
||||
|
||||
(terminal-action eval-identifier $identifier cdr)
|
||||
(terminal-action eval-number $number cdr)
|
||||
(terminal-action eval-string $string cdr)
|
||||
(%print-actions)
|
||||
|
||||
(%section "Primary Expressions")
|
||||
|
||||
(declare-action eval :primary-rvalue (-> (env) value-or-exception))
|
||||
(production :primary-rvalue (this) primary-rvalue-this
|
||||
((eval (e env))
|
||||
(oneof normal (object-or-null-to-value (& this e)))))
|
||||
(production :primary-rvalue (null) primary-rvalue-null
|
||||
((eval (e env :unused))
|
||||
null-result))
|
||||
(production :primary-rvalue (true) primary-rvalue-true
|
||||
((eval (e env :unused))
|
||||
(boolean-result true)))
|
||||
(production :primary-rvalue (false) primary-rvalue-false
|
||||
((eval (e env :unused))
|
||||
(boolean-result false)))
|
||||
(production :primary-rvalue ($number) primary-rvalue-number
|
||||
((eval (e env :unused))
|
||||
(double-result (eval-number $number))))
|
||||
(production :primary-rvalue ($string) primary-rvalue-string
|
||||
((eval (e env :unused))
|
||||
(string-result (eval-string $string))))
|
||||
(production :primary-rvalue (\( (:comma-expression no-l-value) \)) primary-rvalue-parentheses
|
||||
(eval (eval :comma-expression)))
|
||||
|
||||
(declare-action eval :primary-lvalue (-> (env) reference-or-exception))
|
||||
(production :primary-lvalue ($identifier) primary-lvalue-identifier
|
||||
((eval (e env))
|
||||
(lookup-identifier e (eval-identifier $identifier))))
|
||||
(production :primary-lvalue (\( :lvalue \)) primary-lvalue-parentheses
|
||||
(eval (eval :lvalue)))
|
||||
(%print-actions)
|
||||
|
||||
(%section "Left-Side Expressions")
|
||||
|
||||
(grammar-argument :expr-kind any-value no-l-value)
|
||||
(grammar-argument :member-expr-kind call no-call)
|
||||
|
||||
(declare-action eval (:member-lvalue :member-expr-kind) (-> (env) reference-or-exception))
|
||||
(production (:member-lvalue no-call) (:primary-lvalue) member-lvalue-primary-lvalue
|
||||
(eval (eval :primary-lvalue)))
|
||||
(production (:member-lvalue call) (:lvalue :arguments) member-lvalue-call-member-lvalue
|
||||
((eval (e env))
|
||||
(letexc (f-reference reference ((eval :lvalue) e))
|
||||
(letexc (f value (reference-get-value f-reference))
|
||||
(letexc (arguments (vector value) ((eval :arguments) e))
|
||||
(let ((this object-or-null
|
||||
(case f-reference
|
||||
(((value-reference virtual-reference)) (oneof null-object-or-null))
|
||||
((place-reference p place) (oneof object-object-or-null (& base p))))))
|
||||
(call-object f this arguments)))))))
|
||||
(production (:member-lvalue call) ((:member-expression no-call no-l-value) :arguments) member-lvalue-call-member-expression-no-call
|
||||
((eval (e env))
|
||||
(letexc (f value ((eval :member-expression) e))
|
||||
(letexc (arguments (vector value) ((eval :arguments) e))
|
||||
(call-object f (oneof null-object-or-null) arguments)))))
|
||||
(production (:member-lvalue :member-expr-kind) ((:member-expression :member-expr-kind any-value) \[ :expression \]) member-lvalue-array
|
||||
((eval (e env))
|
||||
(letexc (container value ((eval :member-expression) e))
|
||||
(letexc (property value ((eval :expression) e))
|
||||
(read-property container property)))))
|
||||
(production (:member-lvalue :member-expr-kind) ((:member-expression :member-expr-kind any-value) \. $identifier) member-lvalue-property
|
||||
((eval (e env))
|
||||
(letexc (container value ((eval :member-expression) e))
|
||||
(read-property container (oneof string-value (eval-identifier $identifier))))))
|
||||
|
||||
(declare-action eval (:member-expression :member-expr-kind :expr-kind) (-> (env) value-or-exception))
|
||||
(%rule (:member-expression no-call no-l-value))
|
||||
(%rule (:member-expression no-call any-value))
|
||||
(%rule (:member-expression call any-value))
|
||||
(production (:member-expression no-call :expr-kind) (:primary-rvalue) member-expression-primary-rvalue
|
||||
(eval (eval :primary-rvalue)))
|
||||
(production (:member-expression :member-expr-kind any-value) ((:member-lvalue :member-expr-kind)) member-expression-member-lvalue
|
||||
((eval (e env))
|
||||
(letexc (ref reference ((eval :member-lvalue) e))
|
||||
(reference-get-value ref))))
|
||||
(production (:member-expression no-call :expr-kind) (new (:member-expression no-call any-value) :arguments) member-expression-new
|
||||
((eval (e env))
|
||||
(letexc (constructor value ((eval :member-expression) e))
|
||||
(letexc (arguments (vector value) ((eval :arguments) e))
|
||||
(construct-object constructor arguments)))))
|
||||
|
||||
(declare-action eval (:new-expression :expr-kind) (-> (env) value-or-exception))
|
||||
(production (:new-expression :expr-kind) ((:member-expression no-call :expr-kind)) new-expression-member-expression
|
||||
(eval (eval :member-expression)))
|
||||
(production (:new-expression :expr-kind) (new (:new-expression any-value)) new-expression-new
|
||||
((eval (e env))
|
||||
(letexc (constructor value ((eval :new-expression) e))
|
||||
(construct-object constructor (vector-of value)))))
|
||||
|
||||
(declare-action eval :arguments (-> (env) value-list-or-exception))
|
||||
(production :arguments (\( \)) arguments-empty
|
||||
((eval (e env :unused))
|
||||
(oneof normal (vector-of value))))
|
||||
(production :arguments (\( :argument-list \)) arguments-list
|
||||
(eval (eval :argument-list)))
|
||||
|
||||
(declare-action eval :argument-list (-> (env) value-list-or-exception))
|
||||
(production :argument-list ((:assignment-expression any-value)) argument-list-one
|
||||
((eval (e env))
|
||||
(letexc (arg value ((eval :assignment-expression) e))
|
||||
(oneof normal (vector arg)))))
|
||||
(production :argument-list (:argument-list \, (:assignment-expression any-value)) argument-list-more
|
||||
((eval (e env))
|
||||
(letexc (args (vector value) ((eval :argument-list) e))
|
||||
(letexc (arg value ((eval :assignment-expression) e))
|
||||
(oneof normal (append args (vector arg)))))))
|
||||
|
||||
(declare-action eval :lvalue (-> (env) reference-or-exception))
|
||||
(production :lvalue ((:member-lvalue call)) lvalue-member-lvalue-call
|
||||
(eval (eval :member-lvalue)))
|
||||
(production :lvalue ((:member-lvalue no-call)) lvalue-member-lvalue-no-call
|
||||
(eval (eval :member-lvalue)))
|
||||
(%print-actions)
|
||||
|
||||
(define (read-property (container value) (property value)) reference-or-exception
|
||||
(letexc (obj object (coerce-to-object container))
|
||||
(letexc (name prop-name (coerce-to-string property))
|
||||
(oneof normal (oneof place-reference (tuple place obj name))))))
|
||||
|
||||
(define (call-object (f value) (this object-or-null) (arguments (vector value))) reference-or-exception
|
||||
(case f
|
||||
(((undefined-value null-value boolean-value double-value string-value))
|
||||
(typed-oneof reference-or-exception abrupt (make-error (oneof coerce-to-object-error))))
|
||||
((object-value o object)
|
||||
((& call o) this arguments))))
|
||||
|
||||
(define (construct-object (constructor value) (arguments (vector value))) value-or-exception
|
||||
(case constructor
|
||||
(((undefined-value null-value boolean-value double-value string-value))
|
||||
(typed-oneof value-or-exception abrupt (make-error (oneof coerce-to-object-error))))
|
||||
((object-value o object)
|
||||
(letexc (res object ((& construct o) arguments))
|
||||
(object-result res)))))
|
||||
|
||||
(%section "Postfix Expressions")
|
||||
|
||||
(declare-action eval (:postfix-expression :expr-kind) (-> (env) value-or-exception))
|
||||
(production (:postfix-expression :expr-kind) ((:new-expression :expr-kind)) postfix-expression-new
|
||||
(eval (eval :new-expression)))
|
||||
(production (:postfix-expression any-value) ((:member-expression call any-value)) postfix-expression-member-expression-call
|
||||
(eval (eval :member-expression)))
|
||||
(production (:postfix-expression :expr-kind) (:lvalue ++) postfix-expression-increment
|
||||
((eval (e env))
|
||||
(letexc (operand-reference reference ((eval :lvalue) e))
|
||||
(letexc (operand-value value (reference-get-value operand-reference))
|
||||
(letexc (operand double (coerce-to-double operand-value))
|
||||
(letexc (u void (reference-put-value operand-reference (oneof double-value (double-add operand 1.0)))
|
||||
:unused)
|
||||
(double-result operand)))))))
|
||||
(production (:postfix-expression :expr-kind) (:lvalue --) postfix-expression-decrement
|
||||
((eval (e env))
|
||||
(letexc (operand-reference reference ((eval :lvalue) e))
|
||||
(letexc (operand-value value (reference-get-value operand-reference))
|
||||
(letexc (operand double (coerce-to-double operand-value))
|
||||
(letexc (u void (reference-put-value operand-reference (oneof double-value (double-subtract operand 1.0)))
|
||||
:unused)
|
||||
(double-result operand)))))))
|
||||
(%print-actions)
|
||||
|
||||
(%section "Unary Operators")
|
||||
|
||||
(declare-action eval (:unary-expression :expr-kind) (-> (env) value-or-exception))
|
||||
(production (:unary-expression :expr-kind) ((:postfix-expression :expr-kind)) unary-expression-postfix
|
||||
(eval (eval :postfix-expression)))
|
||||
(production (:unary-expression :expr-kind) (delete :lvalue) unary-expression-delete
|
||||
((eval (e env))
|
||||
(letexc (rv reference ((eval :lvalue) e))
|
||||
(case rv
|
||||
(value-reference (typed-oneof value-or-exception abrupt (make-error (oneof delete-error))))
|
||||
((place-reference r place)
|
||||
(letexc (b boolean ((& delete (& base r)) (& property r)))
|
||||
(boolean-result b)))
|
||||
(virtual-reference (boolean-result true))))))
|
||||
(production (:unary-expression :expr-kind) (void (:unary-expression any-value)) unary-expression-void
|
||||
((eval (e env))
|
||||
(letexc (operand value ((eval :unary-expression) e) :unused)
|
||||
undefined-result)))
|
||||
(production (:unary-expression :expr-kind) (typeof :lvalue) unary-expression-typeof-lvalue
|
||||
((eval (e env))
|
||||
(letexc (rv reference ((eval :lvalue) e))
|
||||
(case rv
|
||||
((value-reference v value) (string-result (value-typeof v)))
|
||||
((place-reference r place)
|
||||
(letexc (v value ((& get (& base r)) (& property r)))
|
||||
(string-result (value-typeof v))))
|
||||
(virtual-reference (string-result "undefined"))))))
|
||||
(production (:unary-expression :expr-kind) (typeof (:unary-expression no-l-value)) unary-expression-typeof-expression
|
||||
((eval (e env))
|
||||
(letexc (v value ((eval :unary-expression) e))
|
||||
(string-result (value-typeof v)))))
|
||||
(production (:unary-expression :expr-kind) (++ :lvalue) unary-expression-increment
|
||||
((eval (e env))
|
||||
(letexc (operand-reference reference ((eval :lvalue) e))
|
||||
(letexc (operand-value value (reference-get-value operand-reference))
|
||||
(letexc (operand double (coerce-to-double operand-value))
|
||||
(let ((res double (double-add operand 1.0)))
|
||||
(letexc (u void (reference-put-value operand-reference (oneof double-value res)) :unused)
|
||||
(double-result res))))))))
|
||||
(production (:unary-expression :expr-kind) (-- :lvalue) unary-expression-decrement
|
||||
((eval (e env))
|
||||
(letexc (operand-reference reference ((eval :lvalue) e))
|
||||
(letexc (operand-value value (reference-get-value operand-reference))
|
||||
(letexc (operand double (coerce-to-double operand-value))
|
||||
(let ((res double (double-subtract operand 1.0)))
|
||||
(letexc (u void (reference-put-value operand-reference (oneof double-value res)) :unused)
|
||||
(double-result res))))))))
|
||||
(production (:unary-expression :expr-kind) (+ (:unary-expression any-value)) unary-expression-plus
|
||||
((eval (e env))
|
||||
(letexc (operand-value value ((eval :unary-expression) e))
|
||||
(letexc (operand double (coerce-to-double operand-value))
|
||||
(double-result operand)))))
|
||||
(production (:unary-expression :expr-kind) (- (:unary-expression any-value)) unary-expression-minus
|
||||
((eval (e env))
|
||||
(letexc (operand-value value ((eval :unary-expression) e))
|
||||
(letexc (operand double (coerce-to-double operand-value))
|
||||
(double-result (double-negate operand))))))
|
||||
(production (:unary-expression :expr-kind) (~ (:unary-expression any-value)) unary-expression-bitwise-not
|
||||
((eval (e env))
|
||||
(letexc (operand-value value ((eval :unary-expression) e))
|
||||
(letexc (operand integer (coerce-to-int32 operand-value))
|
||||
(integer-result (bitwise-xor operand -1))))))
|
||||
(production (:unary-expression :expr-kind) (! (:unary-expression any-value)) unary-expression-logical-not
|
||||
((eval (e env))
|
||||
(letexc (operand-value value ((eval :unary-expression) e))
|
||||
(boolean-result (not (coerce-to-boolean operand-value))))))
|
||||
(%print-actions)
|
||||
|
||||
(define (value-typeof (v value)) string
|
||||
(case v
|
||||
(undefined-value "undefined")
|
||||
(null-value "object")
|
||||
(boolean-value "boolean")
|
||||
(double-value "number")
|
||||
(string-value "string")
|
||||
((object-value o object) (& typeof-name o))))
|
||||
|
||||
(%section "Multiplicative Operators")
|
||||
|
||||
(declare-action eval (:multiplicative-expression :expr-kind) (-> (env) value-or-exception))
|
||||
(production (:multiplicative-expression :expr-kind) ((:unary-expression :expr-kind)) multiplicative-expression-unary
|
||||
(eval (eval :unary-expression)))
|
||||
(production (:multiplicative-expression :expr-kind) ((:multiplicative-expression any-value) * (:unary-expression any-value)) multiplicative-expression-multiply
|
||||
((eval (e env))
|
||||
(letexc (left-value value ((eval :multiplicative-expression) e))
|
||||
(letexc (right-value value ((eval :unary-expression) e))
|
||||
(apply-binary-double-operator double-multiply left-value right-value)))))
|
||||
(production (:multiplicative-expression :expr-kind) ((:multiplicative-expression any-value) / (:unary-expression any-value)) multiplicative-expression-divide
|
||||
((eval (e env))
|
||||
(letexc (left-value value ((eval :multiplicative-expression) e))
|
||||
(letexc (right-value value ((eval :unary-expression) e))
|
||||
(apply-binary-double-operator double-divide left-value right-value)))))
|
||||
(production (:multiplicative-expression :expr-kind) ((:multiplicative-expression any-value) % (:unary-expression any-value)) multiplicative-expression-remainder
|
||||
((eval (e env))
|
||||
(letexc (left-value value ((eval :multiplicative-expression) e))
|
||||
(letexc (right-value value ((eval :unary-expression) e))
|
||||
(apply-binary-double-operator double-remainder left-value right-value)))))
|
||||
(%print-actions)
|
||||
|
||||
(define (apply-binary-double-operator (operator (-> (double double) double)) (left-value value) (right-value value)) value-or-exception
|
||||
(letexc (left-number double (coerce-to-double left-value))
|
||||
(letexc (right-number double (coerce-to-double right-value))
|
||||
(double-result (operator left-number right-number)))))
|
||||
|
||||
(%section "Additive Operators")
|
||||
|
||||
(declare-action eval (:additive-expression :expr-kind) (-> (env) value-or-exception))
|
||||
(production (:additive-expression :expr-kind) ((:multiplicative-expression :expr-kind)) additive-expression-multiplicative
|
||||
(eval (eval :multiplicative-expression)))
|
||||
(production (:additive-expression :expr-kind) ((:additive-expression any-value) + (:multiplicative-expression any-value)) additive-expression-add
|
||||
((eval (e env))
|
||||
(letexc (left-value value ((eval :additive-expression) e))
|
||||
(letexc (right-value value ((eval :multiplicative-expression) e))
|
||||
(letexc (left-primitive value (coerce-to-primitive left-value (oneof no-hint)))
|
||||
(letexc (right-primitive value (coerce-to-primitive right-value (oneof no-hint)))
|
||||
(if (or (is string-value left-primitive) (is string-value right-primitive))
|
||||
(letexc (left-string string (coerce-to-string left-primitive))
|
||||
(letexc (right-string string (coerce-to-string right-primitive))
|
||||
(string-result (append left-string right-string))))
|
||||
(apply-binary-double-operator double-add left-primitive right-primitive))))))))
|
||||
(production (:additive-expression :expr-kind) ((:additive-expression any-value) - (:multiplicative-expression any-value)) additive-expression-subtract
|
||||
((eval (e env))
|
||||
(letexc (left-value value ((eval :additive-expression) e))
|
||||
(letexc (right-value value ((eval :multiplicative-expression) e))
|
||||
(apply-binary-double-operator double-subtract left-value right-value)))))
|
||||
(%print-actions)
|
||||
|
||||
(%section "Bitwise Shift Operators")
|
||||
|
||||
(declare-action eval (:shift-expression :expr-kind) (-> (env) value-or-exception))
|
||||
(production (:shift-expression :expr-kind) ((:additive-expression :expr-kind)) shift-expression-additive
|
||||
(eval (eval :additive-expression)))
|
||||
(production (:shift-expression :expr-kind) ((:shift-expression any-value) << (:additive-expression any-value)) shift-expression-left
|
||||
((eval (e env))
|
||||
(letexc (bitmap-value value ((eval :shift-expression) e))
|
||||
(letexc (count-value value ((eval :additive-expression) e))
|
||||
(letexc (bitmap integer (coerce-to-uint32 bitmap-value))
|
||||
(letexc (count integer (coerce-to-uint32 count-value))
|
||||
(integer-result (uint32-to-int32 (bitwise-and (bitwise-shift bitmap (bitwise-and count #x1F))
|
||||
#xFFFFFFFF)))))))))
|
||||
(production (:shift-expression :expr-kind) ((:shift-expression any-value) >> (:additive-expression any-value)) shift-expression-right-signed
|
||||
((eval (e env))
|
||||
(letexc (bitmap-value value ((eval :shift-expression) e))
|
||||
(letexc (count-value value ((eval :additive-expression) e))
|
||||
(letexc (bitmap integer (coerce-to-int32 bitmap-value))
|
||||
(letexc (count integer (coerce-to-uint32 count-value))
|
||||
(integer-result (bitwise-shift bitmap (neg (bitwise-and count #x1F))))))))))
|
||||
(production (:shift-expression :expr-kind) ((:shift-expression any-value) >>> (:additive-expression any-value)) shift-expression-right-unsigned
|
||||
((eval (e env))
|
||||
(letexc (bitmap-value value ((eval :shift-expression) e))
|
||||
(letexc (count-value value ((eval :additive-expression) e))
|
||||
(letexc (bitmap integer (coerce-to-uint32 bitmap-value))
|
||||
(letexc (count integer (coerce-to-uint32 count-value))
|
||||
(integer-result (bitwise-shift bitmap (neg (bitwise-and count #x1F))))))))))
|
||||
(%print-actions)
|
||||
|
||||
(%section "Relational Operators")
|
||||
|
||||
(declare-action eval (:relational-expression :expr-kind) (-> (env) value-or-exception))
|
||||
(production (:relational-expression :expr-kind) ((:shift-expression :expr-kind)) relational-expression-shift
|
||||
(eval (eval :shift-expression)))
|
||||
(production (:relational-expression :expr-kind) ((:relational-expression any-value) < (:shift-expression any-value)) relational-expression-less
|
||||
((eval (e env))
|
||||
(letexc (left-value value ((eval :relational-expression) e))
|
||||
(letexc (right-value value ((eval :shift-expression) e))
|
||||
(order-values left-value right-value true false)))))
|
||||
(production (:relational-expression :expr-kind) ((:relational-expression any-value) > (:shift-expression any-value)) relational-expression-greater
|
||||
((eval (e env))
|
||||
(letexc (left-value value ((eval :relational-expression) e))
|
||||
(letexc (right-value value ((eval :shift-expression) e))
|
||||
(order-values right-value left-value true false)))))
|
||||
(production (:relational-expression :expr-kind) ((:relational-expression any-value) <= (:shift-expression any-value)) relational-expression-less-or-equal
|
||||
((eval (e env))
|
||||
(letexc (left-value value ((eval :relational-expression) e))
|
||||
(letexc (right-value value ((eval :shift-expression) e))
|
||||
(order-values right-value left-value false true)))))
|
||||
(production (:relational-expression :expr-kind) ((:relational-expression any-value) >= (:shift-expression any-value)) relational-expression-greater-or-equal
|
||||
((eval (e env))
|
||||
(letexc (left-value value ((eval :relational-expression) e))
|
||||
(letexc (right-value value ((eval :shift-expression) e))
|
||||
(order-values left-value right-value false true)))))
|
||||
(%print-actions)
|
||||
|
||||
(define (order-values (left-value value) (right-value value) (less boolean) (greater-or-equal boolean)) value-or-exception
|
||||
(letexc (left-primitive value (coerce-to-primitive left-value (oneof number-hint)))
|
||||
(letexc (right-primitive value (coerce-to-primitive right-value (oneof number-hint)))
|
||||
(if (and (is string-value left-primitive) (is string-value right-primitive))
|
||||
(boolean-result
|
||||
(compare-strings (select string-value left-primitive) (select string-value right-primitive) less greater-or-equal greater-or-equal))
|
||||
(letexc (left-number double (coerce-to-double left-primitive))
|
||||
(letexc (right-number double (coerce-to-double right-primitive))
|
||||
(boolean-result (double-compare left-number right-number less greater-or-equal greater-or-equal false))))))))
|
||||
|
||||
(define (compare-strings (left string) (right string) (less boolean) (equal boolean) (greater boolean)) boolean
|
||||
(if (and (empty left) (empty right))
|
||||
equal
|
||||
(if (empty left)
|
||||
less
|
||||
(if (empty right)
|
||||
greater
|
||||
(let ((left-char-code integer (character-to-code (nth left 0)))
|
||||
(right-char-code integer (character-to-code (nth right 0))))
|
||||
(if (< left-char-code right-char-code)
|
||||
less
|
||||
(if (> left-char-code right-char-code)
|
||||
greater
|
||||
(compare-strings (subseq left 1) (subseq right 1) less equal greater))))))))
|
||||
|
||||
(%section "Equality Operators")
|
||||
|
||||
(declare-action eval (:equality-expression :expr-kind) (-> (env) value-or-exception))
|
||||
(production (:equality-expression :expr-kind) ((:relational-expression :expr-kind)) equality-expression-relational
|
||||
(eval (eval :relational-expression)))
|
||||
(production (:equality-expression :expr-kind) ((:equality-expression any-value) == (:relational-expression any-value)) equality-expression-equal
|
||||
((eval (e env))
|
||||
(letexc (left-value value ((eval :equality-expression) e))
|
||||
(letexc (right-value value ((eval :relational-expression) e))
|
||||
(letexc (eq boolean (compare-values left-value right-value))
|
||||
(boolean-result eq))))))
|
||||
(production (:equality-expression :expr-kind) ((:equality-expression any-value) != (:relational-expression any-value)) equality-expression-not-equal
|
||||
((eval (e env))
|
||||
(letexc (left-value value ((eval :equality-expression) e))
|
||||
(letexc (right-value value ((eval :relational-expression) e))
|
||||
(letexc (eq boolean (compare-values left-value right-value))
|
||||
(boolean-result (not eq)))))))
|
||||
(production (:equality-expression :expr-kind) ((:equality-expression any-value) === (:relational-expression any-value)) equality-expression-strict-equal
|
||||
((eval (e env))
|
||||
(letexc (left-value value ((eval :equality-expression) e))
|
||||
(letexc (right-value value ((eval :relational-expression) e))
|
||||
(boolean-result (strict-compare-values left-value right-value))))))
|
||||
(production (:equality-expression :expr-kind) ((:equality-expression any-value) !== (:relational-expression any-value)) equality-expression-strict-not-equal
|
||||
((eval (e env))
|
||||
(letexc (left-value value ((eval :equality-expression) e))
|
||||
(letexc (right-value value ((eval :relational-expression) e))
|
||||
(boolean-result (not (strict-compare-values left-value right-value)))))))
|
||||
(%print-actions)
|
||||
|
||||
(define (compare-values (left-value value) (right-value value)) boolean-or-exception
|
||||
(case left-value
|
||||
(((undefined-value null-value))
|
||||
(case right-value
|
||||
(((undefined-value null-value)) (oneof normal true))
|
||||
(((boolean-value double-value string-value object-value)) (oneof normal false))))
|
||||
((boolean-value left-bool boolean)
|
||||
(case right-value
|
||||
(((undefined-value null-value)) (oneof normal false))
|
||||
((boolean-value right-bool boolean) (oneof normal (not (xor left-bool right-bool))))
|
||||
(((double-value string-value object-value))
|
||||
(compare-double-to-value (coerce-boolean-to-double left-bool) right-value))))
|
||||
((double-value left-number double)
|
||||
(compare-double-to-value left-number right-value))
|
||||
((string-value left-str string)
|
||||
(case right-value
|
||||
(((undefined-value null-value)) (oneof normal false))
|
||||
((boolean-value right-bool boolean)
|
||||
(letexc (left-number double (coerce-to-double left-value))
|
||||
(oneof normal (double-equal left-number (coerce-boolean-to-double right-bool)))))
|
||||
((double-value right-number double)
|
||||
(letexc (left-number double (coerce-to-double left-value))
|
||||
(oneof normal (double-equal left-number right-number))))
|
||||
((string-value right-str string)
|
||||
(oneof normal (compare-strings left-str right-str false true false)))
|
||||
(object-value
|
||||
(letexc (right-primitive value (coerce-to-primitive right-value (oneof no-hint)))
|
||||
(compare-values left-value right-primitive)))))
|
||||
((object-value left-obj object)
|
||||
(case right-value
|
||||
(((undefined-value null-value)) (oneof normal false))
|
||||
((boolean-value right-bool boolean)
|
||||
(letexc (left-primitive value (coerce-to-primitive left-value (oneof no-hint)))
|
||||
(compare-values left-primitive (oneof double-value (coerce-boolean-to-double right-bool)))))
|
||||
(((double-value string-value))
|
||||
(letexc (left-primitive value (coerce-to-primitive left-value (oneof no-hint)))
|
||||
(compare-values left-primitive right-value)))
|
||||
((object-value right-obj object)
|
||||
(oneof normal (address-equal (& properties left-obj) (& properties right-obj))))))))
|
||||
|
||||
(define (compare-double-to-value (left-number double) (right-value value)) boolean-or-exception
|
||||
(case right-value
|
||||
(((undefined-value null-value)) (oneof normal false))
|
||||
(((boolean-value double-value string-value))
|
||||
(letexc (right-number double (coerce-to-double right-value))
|
||||
(oneof normal (double-equal left-number right-number))))
|
||||
(object-value
|
||||
(letexc (right-primitive value (coerce-to-primitive right-value (oneof no-hint)))
|
||||
(compare-double-to-value left-number right-primitive)))))
|
||||
|
||||
(define (double-equal (x double) (y double)) boolean
|
||||
(double-compare x y false true false false))
|
||||
|
||||
(define (strict-compare-values (left-value value) (right-value value)) boolean
|
||||
(case left-value
|
||||
(undefined-value
|
||||
(is undefined-value right-value))
|
||||
(null-value
|
||||
(is null-value right-value))
|
||||
((boolean-value left-bool boolean)
|
||||
(case right-value
|
||||
((boolean-value right-bool boolean) (not (xor left-bool right-bool)))
|
||||
(((undefined-value null-value double-value string-value object-value)) false)))
|
||||
((double-value left-number double)
|
||||
(case right-value
|
||||
((double-value right-number double) (double-equal left-number right-number))
|
||||
(((undefined-value null-value boolean-value string-value object-value)) false)))
|
||||
((string-value left-str string)
|
||||
(case right-value
|
||||
((string-value right-str string)
|
||||
(compare-strings left-str right-str false true false))
|
||||
(((undefined-value null-value boolean-value double-value object-value)) false)))
|
||||
((object-value left-obj object)
|
||||
(case right-value
|
||||
((object-value right-obj object)
|
||||
(address-equal (& properties left-obj) (& properties right-obj)))
|
||||
(((undefined-value null-value boolean-value double-value string-value)) false)))))
|
||||
|
||||
(%section "Binary Bitwise Operators")
|
||||
|
||||
(declare-action eval (:bitwise-and-expression :expr-kind) (-> (env) value-or-exception))
|
||||
(production (:bitwise-and-expression :expr-kind) ((:equality-expression :expr-kind)) bitwise-and-expression-equality
|
||||
(eval (eval :equality-expression)))
|
||||
(production (:bitwise-and-expression :expr-kind) ((:bitwise-and-expression any-value) & (:equality-expression any-value)) bitwise-and-expression-and
|
||||
((eval (e env))
|
||||
(letexc (left-value value ((eval :bitwise-and-expression) e))
|
||||
(letexc (right-value value ((eval :equality-expression) e))
|
||||
(apply-binary-bitwise-operator bitwise-and left-value right-value)))))
|
||||
|
||||
(declare-action eval (:bitwise-xor-expression :expr-kind) (-> (env) value-or-exception))
|
||||
(production (:bitwise-xor-expression :expr-kind) ((:bitwise-and-expression :expr-kind)) bitwise-xor-expression-bitwise-and
|
||||
(eval (eval :bitwise-and-expression)))
|
||||
(production (:bitwise-xor-expression :expr-kind) ((:bitwise-xor-expression any-value) ^ (:bitwise-and-expression any-value)) bitwise-xor-expression-xor
|
||||
((eval (e env))
|
||||
(letexc (left-value value ((eval :bitwise-xor-expression) e))
|
||||
(letexc (right-value value ((eval :bitwise-and-expression) e))
|
||||
(apply-binary-bitwise-operator bitwise-xor left-value right-value)))))
|
||||
|
||||
(declare-action eval (:bitwise-or-expression :expr-kind) (-> (env) value-or-exception))
|
||||
(production (:bitwise-or-expression :expr-kind) ((:bitwise-xor-expression :expr-kind)) bitwise-or-expression-bitwise-xor
|
||||
(eval (eval :bitwise-xor-expression)))
|
||||
(production (:bitwise-or-expression :expr-kind) ((:bitwise-or-expression any-value) \| (:bitwise-xor-expression any-value)) bitwise-or-expression-or
|
||||
((eval (e env))
|
||||
(letexc (left-value value ((eval :bitwise-or-expression) e))
|
||||
(letexc (right-value value ((eval :bitwise-xor-expression) e))
|
||||
(apply-binary-bitwise-operator bitwise-or left-value right-value)))))
|
||||
(%print-actions)
|
||||
|
||||
(define (apply-binary-bitwise-operator (operator (-> (integer integer) integer)) (left-value value) (right-value value)) value-or-exception
|
||||
(letexc (left-int integer (coerce-to-int32 left-value))
|
||||
(letexc (right-int integer (coerce-to-int32 right-value))
|
||||
(integer-result (operator left-int right-int)))))
|
||||
|
||||
(%section "Binary Logical Operators")
|
||||
|
||||
(declare-action eval (:logical-and-expression :expr-kind) (-> (env) value-or-exception))
|
||||
(production (:logical-and-expression :expr-kind) ((:bitwise-or-expression :expr-kind)) logical-and-expression-bitwise-or
|
||||
(eval (eval :bitwise-or-expression)))
|
||||
(production (:logical-and-expression :expr-kind) ((:logical-and-expression any-value) && (:bitwise-or-expression any-value)) logical-and-expression-and
|
||||
((eval (e env))
|
||||
(letexc (left-value value ((eval :logical-and-expression) e))
|
||||
(if (coerce-to-boolean left-value)
|
||||
((eval :bitwise-or-expression) e)
|
||||
(oneof normal left-value)))))
|
||||
|
||||
(declare-action eval (:logical-or-expression :expr-kind) (-> (env) value-or-exception))
|
||||
(production (:logical-or-expression :expr-kind) ((:logical-and-expression :expr-kind)) logical-or-expression-logical-and
|
||||
(eval (eval :logical-and-expression)))
|
||||
(production (:logical-or-expression :expr-kind) ((:logical-or-expression any-value) \|\| (:logical-and-expression any-value)) logical-or-expression-or
|
||||
((eval (e env))
|
||||
(letexc (left-value value ((eval :logical-or-expression) e))
|
||||
(if (coerce-to-boolean left-value)
|
||||
(oneof normal left-value)
|
||||
((eval :logical-and-expression) e)))))
|
||||
(%print-actions)
|
||||
|
||||
(%section "Conditional Operator")
|
||||
|
||||
(declare-action eval (:conditional-expression :expr-kind) (-> (env) value-or-exception))
|
||||
(production (:conditional-expression :expr-kind) ((:logical-or-expression :expr-kind)) conditional-expression-logical-or
|
||||
(eval (eval :logical-or-expression)))
|
||||
(production (:conditional-expression :expr-kind) ((:logical-or-expression any-value) ? (:assignment-expression any-value) \: (:assignment-expression any-value)) conditional-expression-conditional
|
||||
((eval (e env))
|
||||
(letexc (condition value ((eval :logical-or-expression) e))
|
||||
(if (coerce-to-boolean condition)
|
||||
((eval :assignment-expression 1) e)
|
||||
((eval :assignment-expression 2) e)))))
|
||||
(%print-actions)
|
||||
|
||||
(%section "Assignment Operators")
|
||||
|
||||
(declare-action eval (:assignment-expression :expr-kind) (-> (env) value-or-exception))
|
||||
(production (:assignment-expression :expr-kind) ((:conditional-expression :expr-kind)) assignment-expression-conditional
|
||||
(eval (eval :conditional-expression)))
|
||||
(production (:assignment-expression :expr-kind) (:lvalue = (:assignment-expression any-value)) assignment-expression-assignment
|
||||
((eval (e env))
|
||||
(letexc (left-reference reference ((eval :lvalue) e))
|
||||
(letexc (right-value value ((eval :assignment-expression) e))
|
||||
(letexc (u void (reference-put-value left-reference right-value) :unused)
|
||||
(oneof normal right-value))))))
|
||||
#|
|
||||
(production (:assignment-expression :expr-kind) (:lvalue :compound-assignment (:assignment-expression any-value)) assignment-expression-compound-assignment
|
||||
((eval (e env))
|
||||
(letexc (left-reference reference ((eval :lvalue) e))
|
||||
(letexc (left-value value (reference-get-value left-reference))
|
||||
(letexc (right-value value ((eval :assignment-expression) e))
|
||||
(letexc (res-value ((compound-operator :compound-assignment) left-value right-value))
|
||||
(letexc (u void (reference-put-value left-reference res-value) :unused)
|
||||
(oneof normal res-value))))))))
|
||||
|
||||
(declare-action compound-operator :compound-assignment (-> (value value) value-or-exception))
|
||||
(production :compound-assignment (*=) compound-assignment-multiply
|
||||
(compound-operator (binary-double-compound-operator double-multiply)))
|
||||
(production :compound-assignment (/=) compound-assignment-divide
|
||||
(compound-operator (binary-double-compound-operator double-divide)))
|
||||
(production :compound-assignment (%=) compound-assignment-remainder
|
||||
(compound-operator (binary-double-compound-operator double-remainder)))
|
||||
(production :compound-assignment (+=) compound-assignment-add
|
||||
(compound-operator (binary-double-compound-operator double-remainder)))
|
||||
(production :compound-assignment (-=) compound-assignment-subtract
|
||||
(compound-operator (binary-double-compound-operator double-subtract)))
|
||||
(%print-actions)
|
||||
|
||||
(define (binary-double-compound-operator (operator (-> (double double) double))) (-> (value value) value-or-exception)
|
||||
(function ((left-value value) (right-value value))
|
||||
(letexc (left-number double (coerce-to-double left-value))
|
||||
(letexc (right-number double (coerce-to-double right-value))
|
||||
(oneof normal (oneof double-value (operator left-number right-number)))))))
|
||||
|#
|
||||
(%section "Expressions")
|
||||
|
||||
(declare-action eval (:comma-expression :expr-kind) (-> (env) value-or-exception))
|
||||
(production (:comma-expression :expr-kind) ((:assignment-expression :expr-kind)) comma-expression-assignment
|
||||
(eval (eval :assignment-expression)))
|
||||
(%print-actions)
|
||||
|
||||
(declare-action eval :expression (-> (env) value-or-exception))
|
||||
(production :expression ((:comma-expression any-value)) expression-comma-expression
|
||||
(eval (eval :comma-expression)))
|
||||
(%print-actions)
|
||||
|
||||
(%section "Programs")
|
||||
|
||||
(declare-action eval :program value-or-exception)
|
||||
(production :program (:expression $end) program
|
||||
(eval ((eval :expression) (tuple env (oneof null-object-or-null)))))
|
||||
)))
|
||||
|
||||
(defparameter *gg* (world-grammar *gw* 'code-grammar)))
|
||||
|
||||
|
||||
(defun token-terminal (token)
|
||||
(if (symbolp token)
|
||||
token
|
||||
(car token)))
|
||||
|
||||
(defun ecma-parse-tokens (tokens &key trace)
|
||||
(action-parse *gg* #'token-terminal tokens :trace trace))
|
||||
|
||||
|
||||
(defun ecma-parse (string &key trace)
|
||||
(let ((tokens (tokenize string)))
|
||||
(when trace
|
||||
(format *trace-output* "~S~%" tokens))
|
||||
(action-parse *gg* #'token-terminal tokens :trace trace)))
|
||||
|
||||
|
||||
; Same as ecma-parse except that also print the action results nicely.
|
||||
(defun ecma-pparse (string &key (stream t) trace)
|
||||
(multiple-value-bind (results types) (ecma-parse string :trace trace)
|
||||
(print-values results types stream)
|
||||
(terpri stream)
|
||||
(values results types)))
|
||||
|
||||
|
||||
#|
|
||||
(depict-rtf-to-local-file
|
||||
";JSECMA;ParserSemantics.rtf"
|
||||
"ECMAScript 1 Parser Semantics"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *gw*)))
|
||||
|
||||
(depict-html-to-local-file
|
||||
";JSECMA;ParserSemantics.html"
|
||||
"ECMAScript 1 Parser Semantics"
|
||||
t
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *gw*)))
|
||||
|
||||
(with-local-output (s ";JSECMA;ParserGrammar.txt") (print-grammar *gg* s))
|
||||
|
||||
|
||||
(ecma-pparse "('abc')")
|
||||
(ecma-pparse "!~ 352")
|
||||
(ecma-pparse "1e308%.125")
|
||||
(ecma-pparse "-3>>>10-6")
|
||||
(ecma-pparse "-3>>0")
|
||||
(ecma-pparse "1+2*3|16")
|
||||
(ecma-pparse "1==true")
|
||||
(ecma-pparse "1=true")
|
||||
(ecma-pparse "x=true")
|
||||
(ecma-pparse "2*4+17+0x32")
|
||||
(ecma-pparse "+'ab'+'de'")
|
||||
|#
|
||||
|
|
@ -24,24 +24,62 @@
|
|||
;;;
|
||||
|
||||
|
||||
#+allegro (shadow 'state)
|
||||
#+allegro (shadow 'type)
|
||||
|
||||
(defparameter *semantic-engine-filenames*
|
||||
'("Utilities" "Markup" "RTF" "HTML" "GrammarSymbol" "Grammar" "Parser" "Metaparser" "Lexer" "Calculus" "CalculusMarkup"
|
||||
";JS20;Parser" ";JS20;Lexer" ";JS20;RegExp" #|"JSECMA;Lexer" "JSECMA;Parser"|# ))
|
||||
'("Utilities" "Markup" "RTF" "HTML" "GrammarSymbol" "Grammar" "Parser" "Metaparser" "Lexer" "Calculus" "CalculusMarkup"))
|
||||
|
||||
(defparameter *semantics-filenames*
|
||||
'("JS20/Parser" "JS20/Lexer" "JS20/RegExp" #|"JSECMA/Lexer" "JSECMA/Parser"|# ))
|
||||
|
||||
(defparameter *semantic-engine-directory*
|
||||
(make-pathname
|
||||
:directory (pathname-directory (truename *loading-file-source-file*))))
|
||||
:directory (pathname-directory #-mcl *load-truename*
|
||||
#+mcl (truename *loading-file-source-file*))))
|
||||
|
||||
|
||||
;;; Convert a filename string possibly containing slashes into a Lisp relative pathname.
|
||||
(defun filename-to-relative-pathname (filename)
|
||||
(let ((directories nil))
|
||||
(loop
|
||||
(let ((slash (position #\/ filename)))
|
||||
(if slash
|
||||
(progn
|
||||
(push (subseq filename 0 slash) directories)
|
||||
(setq filename (subseq filename (1+ slash))))
|
||||
(return (if directories
|
||||
(make-pathname :directory (cons ':relative (nreverse directories)) :name filename)
|
||||
filename)))))))
|
||||
|
||||
|
||||
;;; Convert a filename string possibly containing slashes relative to *semantic-engine-directory*
|
||||
;;; into a Lisp absolute pathname.
|
||||
(defun filename-to-semantic-engine-pathname (filename)
|
||||
(merge-pathnames (filename-to-relative-pathname filename) *semantic-engine-directory*))
|
||||
|
||||
|
||||
(defun operate-on-files (f files &rest options)
|
||||
(with-compilation-unit ()
|
||||
(dolist (filename files)
|
||||
(apply f (filename-to-semantic-engine-pathname filename) :verbose t options))))
|
||||
|
||||
(defun compile-semantic-engine ()
|
||||
(operate-on-files #'compile-file *semantic-engine-filenames* :load t))
|
||||
|
||||
(defun load-semantic-engine ()
|
||||
(dolist (filename *semantic-engine-filenames*)
|
||||
(let ((pathname (merge-pathnames filename *semantic-engine-directory*)))
|
||||
(load pathname :verbose t))))
|
||||
(operate-on-files #-allegro #'load #+allegro #'load-compiled *semantic-engine-filenames*))
|
||||
|
||||
(defun load-semantics ()
|
||||
(operate-on-files #'load *semantics-filenames*))
|
||||
|
||||
|
||||
(defmacro with-local-output ((stream filename) &body body)
|
||||
`(with-open-file (,stream (merge-pathnames ,filename *semantic-engine-directory*)
|
||||
`(with-open-file (,stream (filename-to-semantic-engine-pathname ,filename)
|
||||
:direction :output
|
||||
:if-exists :supersede)
|
||||
,@body))
|
||||
|
||||
|
||||
(load-semantic-engine)
|
||||
(load-semantics)
|
||||
|
|
|
|||
|
|
@ -225,14 +225,14 @@
|
|||
(substitute-soft-breaks
|
||||
tree
|
||||
#'(lambda (soft-break)
|
||||
(list (make-string (soft-break-width soft-break) :initial-element #\space :element-type 'base-character)))))
|
||||
(list (make-string (soft-break-width soft-break) :initial-element #\space :element-type #-mcl 'character #+mcl 'base-character)))))
|
||||
|
||||
|
||||
; Return a freshly consed markup list for a hard line break followed by indent spaces.
|
||||
(defun hard-break-markup (indent)
|
||||
(if (zerop indent)
|
||||
(list ':new-line)
|
||||
(list ':new-line (make-string indent :initial-element #\space :element-type 'base-character))))
|
||||
(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
|
||||
|
|
@ -600,7 +600,7 @@
|
|||
; The string should contain only letters, dashes, and numbers.
|
||||
(defun string-to-mixed-case (string &optional capitalize)
|
||||
(let* ((length (length string))
|
||||
(dst-string (make-array length :element-type 'base-character :fill-pointer 0)))
|
||||
(dst-string (make-array length :element-type #-mcl 'character #+mcl 'base-character :fill-pointer 0)))
|
||||
(dotimes (i length)
|
||||
(let ((char (char string i)))
|
||||
(if (eql char #\-)
|
||||
|
|
|
|||
|
|
@ -355,8 +355,8 @@
|
|||
; (an output stream), dividing the text as specified by dynamically scoped calls
|
||||
; to break-line. Return the text as a base-string.
|
||||
(defun write-limited-lines (emitter)
|
||||
(let ((limited-stream (make-string-output-stream :element-type 'base-character))
|
||||
(*current-limited-lines* (make-string-output-stream :element-type 'base-character))
|
||||
(let ((limited-stream (make-string-output-stream :element-type #-mcl 'character #+mcl 'base-character))
|
||||
(*current-limited-lines* (make-string-output-stream :element-type #-mcl 'character #+mcl 'base-character))
|
||||
(*current-limited-lines-non-empty* nil)
|
||||
(*current-limited-position* 0))
|
||||
(funcall emitter limited-stream)
|
||||
|
|
@ -525,7 +525,7 @@
|
|||
; Read RTF from the text file with the given name (relative to the
|
||||
; local directory) and return it in list form.
|
||||
(defun read-rtf-from-local-file (filename)
|
||||
(with-open-file (stream (merge-pathnames filename *semantic-engine-directory*)
|
||||
(with-open-file (stream (filename-to-semantic-engine-pathname filename)
|
||||
:direction :input)
|
||||
(read-rtf stream)))
|
||||
|
||||
|
|
@ -543,7 +543,7 @@
|
|||
(let ((i (position-if #'(lambda (char) (member char *rtf-special*)) string)))
|
||||
(if i
|
||||
(let* ((string-length (length string))
|
||||
(result-string (make-array string-length :element-type 'base-character :adjustable t :fill-pointer i)))
|
||||
(result-string (make-array string-length :element-type #-mcl 'character #+mcl 'base-character :adjustable t :fill-pointer i)))
|
||||
(replace result-string string)
|
||||
(do ((i i (1+ i)))
|
||||
((= i string-length))
|
||||
|
|
@ -632,7 +632,7 @@
|
|||
; Write RTF to the text file with the given name (relative to the
|
||||
; local directory).
|
||||
(defun write-rtf-to-local-file (filename rtf)
|
||||
(with-open-file (stream (merge-pathnames filename *semantic-engine-directory*)
|
||||
(with-open-file (stream (filename-to-semantic-engine-pathname filename)
|
||||
:direction :output
|
||||
:if-exists :supersede
|
||||
#+mcl :external-format #+mcl "RTF "
|
||||
|
|
|
|||
|
|
@ -1,68 +0,0 @@
|
|||
(progn
|
||||
(defparameter *bew*
|
||||
(generate-world
|
||||
"BE"
|
||||
'((lexer base-example-lexer
|
||||
:lalr-1
|
||||
:numeral
|
||||
((:digit (#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
|
||||
((value $digit-value))))
|
||||
(($digit-value integer digit-value digit-char-36)))
|
||||
|
||||
(deftype semantic-exception (oneof syntax-error))
|
||||
|
||||
(%charclass :digit)
|
||||
|
||||
(rule :digits ((decimal-value integer)
|
||||
(base-value (-> (integer) integer)))
|
||||
(production :digits (:digit) digits-first
|
||||
(decimal-value (value :digit))
|
||||
((base-value (base integer))
|
||||
(let ((d integer (value :digit)))
|
||||
(if (< d base) d (throw (oneof syntax-error))))))
|
||||
(production :digits (:digits :digit) digits-rest
|
||||
(decimal-value (+ (* 10 (decimal-value :digits)) (value :digit)))
|
||||
((base-value (base integer))
|
||||
(let ((d integer (value :digit)))
|
||||
(if (< d base)
|
||||
(+ (* base ((base-value :digits) base)) d)
|
||||
(throw (oneof syntax-error)))))))
|
||||
|
||||
(rule :numeral ((value integer))
|
||||
(production :numeral (:digits) numeral-digits
|
||||
(value (decimal-value :digits)))
|
||||
(production :numeral (:digits #\# :digits) numeral-digits-and-base
|
||||
(value
|
||||
(let ((base integer (decimal-value :digits 2)))
|
||||
(if (and (>= base 2) (<= base 10))
|
||||
((base-value :digits 1) base)
|
||||
(throw (oneof syntax-error)))))))
|
||||
(%print-actions)
|
||||
)))
|
||||
|
||||
(defparameter *bel* (world-lexer *bew* 'base-example-lexer))
|
||||
(defparameter *beg* (lexer-grammar *bel*)))
|
||||
|
||||
#|
|
||||
(depict-rtf-to-local-file
|
||||
";Test;BaseExampleSemantics.rtf"
|
||||
"Base Example Semantics"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *bew*)))
|
||||
|
||||
(depict-html-to-local-file
|
||||
";Test;BaseExampleSemantics.html"
|
||||
"Base Example Semantics"
|
||||
t
|
||||
#'(lambda (html-stream)
|
||||
(depict-world-commands html-stream *bew*))
|
||||
:external-link-base "")
|
||||
|
||||
|
||||
(lexer-pparse *bel* "37")
|
||||
(lexer-pparse *bel* "33#4")
|
||||
(lexer-pparse *bel* "30#2")
|
||||
|
||||
|#
|
||||
|
||||
(length (grammar-states *beg*))
|
||||
|
|
@ -1,71 +0,0 @@
|
|||
;;; The contents of this file are subject to the Mozilla Public
|
||||
;;; License Version 1.1 (the "License"); you may not use this file
|
||||
;;; except in compliance with the License. You may obtain a copy of
|
||||
;;; the License at http://www.mozilla.org/MPL/
|
||||
;;;
|
||||
;;; Software distributed under the License is distributed on an "AS
|
||||
;;; IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
|
||||
;;; implied. See the License for the specific language governing
|
||||
;;; rights and limitations under the License.
|
||||
;;;
|
||||
;;; The Original Code is the Language Design and Prototyping Environment.
|
||||
;;;
|
||||
;;; The Initial Developer of the Original Code is Netscape Communications
|
||||
;;; Corporation. Portions created by Netscape Communications Corporation are
|
||||
;;; Copyright (C) 1999 Netscape Communications Corporation. All
|
||||
;;; Rights Reserved.
|
||||
;;;
|
||||
;;; Contributor(s): Waldemar Horwat <waldemar@acm.org>
|
||||
|
||||
;;;
|
||||
;;; Constraint test grammar
|
||||
;;;
|
||||
;;; Waldemar Horwat (waldemar@acm.org)
|
||||
;;;
|
||||
|
||||
(declaim (optimize (debug 3)))
|
||||
|
||||
(progn
|
||||
(defparameter *ctw*
|
||||
(generate-world
|
||||
"T"
|
||||
'((grammar constraint-test-grammar :lr-1 :start)
|
||||
|
||||
(production :start (:string) start-string)
|
||||
(production :start ((:- letter digit) :chars) start-escape)
|
||||
(production :start ((:- escape) :char) start-letter-digit)
|
||||
|
||||
(production :string (begin :chars end) string)
|
||||
|
||||
(production :chars () chars-none)
|
||||
(production :chars (:chars :char) chars-some)
|
||||
|
||||
(production :char (letter (:- letter)) char-letter)
|
||||
(production :char (digit) char-digit)
|
||||
(production :char (escape digit (:- digit)) char-escape-1)
|
||||
(production :char (escape digit digit) char-escape-2)
|
||||
)))
|
||||
|
||||
(defparameter *ctg* (world-grammar *ctw* 'constraint-test-grammar)))
|
||||
|
||||
|
||||
#|
|
||||
(depict-rtf-to-local-file
|
||||
";Test;ConstraintTestGrammar.rtf"
|
||||
"Constraint Test Grammar"
|
||||
#'(lambda (markup-stream)
|
||||
(depict-world-commands markup-stream *ctw* :visible-semantics nil)))
|
||||
|
||||
(depict-html-to-local-file
|
||||
";Test;ConstraintTestGrammar.html"
|
||||
"Constraint Test Grammar"
|
||||
t
|
||||
#'(lambda (markup-stream)
|
||||
(depict-world-commands markup-stream *ctw* :visible-semantics nil)))
|
||||
|
||||
(with-local-output (s ";Test;ConstraintTestGrammar.txt") (print-grammar *ctg* s))
|
||||
|
||||
(pprint (parse *ctg* #'identity '(begin letter letter letter digit end)))
|
||||
|#
|
||||
|
||||
(length (grammar-states *ctg*))
|
||||
|
|
@ -20,13 +20,13 @@
|
|||
|
||||
#|
|
||||
(depict-rtf-to-local-file
|
||||
";Test;StandardFunctionSemantics.rtf"
|
||||
"Test/StandardFunctionSemantics.rtf"
|
||||
"Standard Function Semantics"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *sfw*)))
|
||||
|
||||
(depict-html-to-local-file
|
||||
";Test;StandardFunctionSemantics.html"
|
||||
"Test/StandardFunctionSemantics.html"
|
||||
"Standard Function Semantics"
|
||||
t
|
||||
#'(lambda (html-stream)
|
||||
|
|
|
|||
|
|
@ -1,56 +0,0 @@
|
|||
(progn
|
||||
(defparameter *tcw*
|
||||
(generate-world
|
||||
"TC"
|
||||
'((lexer throw-catch-lexer
|
||||
:lalr-1
|
||||
:main
|
||||
((:digit (#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
|
||||
((value $digit-value))))
|
||||
(($digit-value integer digit-value digit-char-36)))
|
||||
|
||||
(%charclass :digit)
|
||||
|
||||
(deftype semantic-exception integer)
|
||||
|
||||
(rule :expr ((value (-> () integer)))
|
||||
(production :expr (:digit) expr-digit
|
||||
((value) (value :digit)))
|
||||
(production :expr (#\t :expr) expr-throw
|
||||
((value) (throw ((value :expr)))))
|
||||
(production :expr (#\c #\{ :expr #\} :expr) expr-catch
|
||||
((value) (catch ((value :expr 1))
|
||||
(e) (+ (* e 10) ((value :expr 2)))))))
|
||||
|
||||
(rule :main ((value integer))
|
||||
(production :main (:expr) main-expr
|
||||
(value ((value :expr)))))
|
||||
(%print-actions)
|
||||
)))
|
||||
|
||||
(defparameter *tcl* (world-lexer *tcw* 'throw-catch-lexer))
|
||||
(defparameter *tcg* (lexer-grammar *tcl*)))
|
||||
|
||||
#|
|
||||
(depict-rtf-to-local-file
|
||||
";Test;ThrowCatchSemantics.rtf"
|
||||
"Base Example Semantics"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *tcw*)))
|
||||
|
||||
(depict-html-to-local-file
|
||||
";Test;ThrowCatchSemantics.html"
|
||||
"Base Example Semantics"
|
||||
t
|
||||
#'(lambda (html-stream)
|
||||
(depict-world-commands html-stream *tcw*))
|
||||
:external-link-base "")
|
||||
|
||||
|
||||
(lexer-pparse *tcl* "7")
|
||||
(lexer-pparse *tcl* "t3")
|
||||
(lexer-pparse *tcl* "c{t6}5")
|
||||
|
||||
|#
|
||||
|
||||
(length (grammar-states *tcg*))
|
||||
|
|
@ -155,7 +155,8 @@
|
|||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; VALUE ASSERTS
|
||||
|
||||
(defconstant *value-asserts* t)
|
||||
(eval-when (:compile-toplevel :load-toplevel)
|
||||
(defconstant *value-asserts* t))
|
||||
|
||||
; Assert that (test value) returns non-nil. Return value.
|
||||
(defmacro assert-value (value test &rest format-and-parameters)
|
||||
|
|
|
|||
|
|
@ -345,7 +345,7 @@
|
|||
(defun grammar-symbol-= (grammar-symbol1 grammar-symbol2)
|
||||
(eql grammar-symbol1 grammar-symbol2))
|
||||
; A version of grammar-symbol-= suitable for being the test function for hash tables.
|
||||
(defconstant *grammar-symbol-=* #'eql)
|
||||
(defparameter *grammar-symbol-=* #'eql)
|
||||
|
||||
|
||||
; Return the general-grammar-symbol's symbol. Return it unchanged if it is not
|
||||
|
|
|
|||
|
|
@ -322,7 +322,7 @@
|
|||
; Write html to the text file with the given name (relative to the
|
||||
; local directory).
|
||||
(defun write-html-to-local-file (filename html)
|
||||
(with-open-file (stream (merge-pathnames filename *semantic-engine-directory*)
|
||||
(with-open-file (stream (filename-to-semantic-engine-pathname filename)
|
||||
:direction :output
|
||||
:if-exists :supersede
|
||||
#+mcl :mac-file-creator #+mcl "MOSS")
|
||||
|
|
|
|||
|
|
@ -384,17 +384,17 @@
|
|||
|
||||
#|
|
||||
(depict-rtf-to-local-file
|
||||
";JS14;ParserGrammar.rtf"
|
||||
"JS14/ParserGrammar.rtf"
|
||||
"JavaScript 1.4 Parser Grammar"
|
||||
#'(lambda (markup-stream)
|
||||
(depict-world-commands markup-stream *jw* :visible-semantics nil)))
|
||||
|
||||
(depict-html-to-local-file
|
||||
";JS14;ParserGrammar.html"
|
||||
"JS14/ParserGrammar.html"
|
||||
"JavaScript 1.4 Parser Grammar"
|
||||
t
|
||||
#'(lambda (markup-stream)
|
||||
(depict-world-commands markup-stream *jw* :visible-semantics nil)))
|
||||
|
||||
(with-local-output (s ";JS14;ParserGrammar.txt") (print-grammar *jg* s))
|
||||
(with-local-output (s "JS14/ParserGrammar.txt") (print-grammar *jg* s))
|
||||
|#
|
||||
|
|
|
|||
|
|
@ -524,7 +524,7 @@
|
|||
|
||||
#|
|
||||
(depict-rtf-to-local-file
|
||||
";JS20;LexerCharClasses.rtf"
|
||||
"JS20/LexerCharClasses.rtf"
|
||||
"JavaScript 2 Lexer Character Classes"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-paragraph (rtf-stream ':grammar-header)
|
||||
|
|
@ -537,33 +537,33 @@
|
|||
|
||||
(progn
|
||||
(depict-rtf-to-local-file
|
||||
";JS20;LexerGrammar.rtf"
|
||||
"JS20/LexerGrammar.rtf"
|
||||
"JavaScript 2 Lexer Grammar"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *lw* :visible-semantics nil)))
|
||||
(depict-rtf-to-local-file
|
||||
";JS20;LexerSemantics.rtf"
|
||||
"JS20/LexerSemantics.rtf"
|
||||
"JavaScript 2 Lexer Semantics"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *lw*))))
|
||||
|
||||
(progn
|
||||
(depict-html-to-local-file
|
||||
";JS20;LexerGrammar.html"
|
||||
"JS20/LexerGrammar.html"
|
||||
"JavaScript 2 Lexer Grammar"
|
||||
t
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *lw* :visible-semantics nil))
|
||||
:external-link-base "notation.html")
|
||||
(depict-html-to-local-file
|
||||
";JS20;LexerSemantics.html"
|
||||
"JS20/LexerSemantics.html"
|
||||
"JavaScript 2 Lexer Semantics"
|
||||
t
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *lw*))
|
||||
:external-link-base "notation.html"))
|
||||
|
||||
(with-local-output (s ";JS20;LexerGrammar.txt") (print-lexer *ll* s) (print-grammar *lg* s))
|
||||
(with-local-output (s "JS20/LexerGrammar.txt") (print-lexer *ll* s) (print-grammar *lg* s))
|
||||
|
||||
(print-illegal-strings m)
|
||||
|#
|
||||
|
|
|
|||
|
|
@ -634,21 +634,21 @@
|
|||
|
||||
#|
|
||||
(depict-rtf-to-local-file
|
||||
";JS20;ParserGrammar.rtf"
|
||||
"JS20/ParserGrammar.rtf"
|
||||
"JavaScript 2.0 Parser Grammar"
|
||||
#'(lambda (markup-stream)
|
||||
(depict-js-terminals markup-stream *jg*)
|
||||
(depict-world-commands markup-stream *jw* :visible-semantics nil)))
|
||||
|
||||
(depict-html-to-local-file
|
||||
";JS20;ParserGrammar.html"
|
||||
"JS20/ParserGrammar.html"
|
||||
"JavaScript 2.0 Parser Grammar"
|
||||
t
|
||||
#'(lambda (markup-stream)
|
||||
(depict-js-terminals markup-stream *jg*)
|
||||
(depict-world-commands markup-stream *jw* :visible-semantics nil)))
|
||||
|
||||
(with-local-output (s ";JS20;ParserGrammar.txt") (print-grammar *jg* s))
|
||||
(with-local-output (s "JS20/ParserGrammar.txt") (print-grammar *jg* s))
|
||||
|#
|
||||
|
||||
(length (grammar-states *jg*))
|
||||
|
|
|
|||
|
|
@ -586,33 +586,33 @@
|
|||
#|
|
||||
(progn
|
||||
(depict-rtf-to-local-file
|
||||
";JS20;RegExpGrammar.rtf"
|
||||
"JS20/RegExpGrammar.rtf"
|
||||
"Regular Expression Grammar"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *rw* :visible-semantics nil)))
|
||||
(depict-rtf-to-local-file
|
||||
";JS20;RegExpSemantics.rtf"
|
||||
"JS20/RegExpSemantics.rtf"
|
||||
"Regular Expression Semantics"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *rw*))))
|
||||
|
||||
(progn
|
||||
(depict-html-to-local-file
|
||||
";JS20;RegExpGrammar.html"
|
||||
"JS20/RegExpGrammar.html"
|
||||
"Regular Expression Grammar"
|
||||
t
|
||||
#'(lambda (html-stream)
|
||||
(depict-world-commands html-stream *rw* :visible-semantics nil))
|
||||
:external-link-base "notation.html")
|
||||
(depict-html-to-local-file
|
||||
";JS20;RegExpSemantics.html"
|
||||
"JS20/RegExpSemantics.html"
|
||||
"Regular Expression Semantics"
|
||||
t
|
||||
#'(lambda (html-stream)
|
||||
(depict-world-commands html-stream *rw*))
|
||||
:external-link-base "notation.html"))
|
||||
|
||||
(with-local-output (s ";JS20;RegExpGrammar.txt") (print-lexer *rl* s) (print-grammar *rg* s))
|
||||
(with-local-output (s "JS20/RegExpGrammar.txt") (print-lexer *rl* s) (print-grammar *rg* s))
|
||||
|
||||
(lexer-pparse *rl* "a+" :trace t)
|
||||
(lexer-pparse *rl* "[]+" :trace t)
|
||||
|
|
|
|||
|
|
@ -428,7 +428,7 @@
|
|||
|
||||
#|
|
||||
(depict-rtf-to-local-file
|
||||
";JSECMA;LexerCharClasses.rtf"
|
||||
"JSECMA/LexerCharClasses.rtf"
|
||||
"ECMAScript 1 Lexer Character Classes"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-paragraph (rtf-stream ':grammar-header)
|
||||
|
|
@ -440,19 +440,19 @@
|
|||
(depict-grammar rtf-stream *lg*)))
|
||||
|
||||
(depict-rtf-to-local-file
|
||||
";JSECMA;LexerSemantics.rtf"
|
||||
"JSECMA/LexerSemantics.rtf"
|
||||
"ECMAScript 1 Lexer Semantics"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *lw*)))
|
||||
|
||||
(depict-html-to-local-file
|
||||
";JSECMA;LexerSemantics.html"
|
||||
"JSECMA/LexerSemantics.html"
|
||||
"ECMAScript 1 Lexer Semantics"
|
||||
t
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *lw*)))
|
||||
|
||||
(with-local-output (s ";JSECMA;LexerGrammar.txt") (print-lexer *ll* s) (print-grammar *lg* s))
|
||||
(with-local-output (s "JSECMA/LexerGrammar.txt") (print-lexer *ll* s) (print-grammar *lg* s))
|
||||
|
||||
(print-illegal-strings m)
|
||||
|
||||
|
|
|
|||
|
|
@ -829,19 +829,19 @@
|
|||
|
||||
#|
|
||||
(depict-rtf-to-local-file
|
||||
";JSECMA;ParserSemantics.rtf"
|
||||
"JSECMA/ParserSemantics.rtf"
|
||||
"ECMAScript 1 Parser Semantics"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *gw*)))
|
||||
|
||||
(depict-html-to-local-file
|
||||
";JSECMA;ParserSemantics.html"
|
||||
"JSECMA/ParserSemantics.html"
|
||||
"ECMAScript 1 Parser Semantics"
|
||||
t
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *gw*)))
|
||||
|
||||
(with-local-output (s ";JSECMA;ParserGrammar.txt") (print-grammar *gg* s))
|
||||
(with-local-output (s "JSECMA/ParserGrammar.txt") (print-grammar *gg* s))
|
||||
|
||||
|
||||
(ecma-pparse "('abc')")
|
||||
|
|
|
|||
|
|
@ -24,24 +24,62 @@
|
|||
;;;
|
||||
|
||||
|
||||
#+allegro (shadow 'state)
|
||||
#+allegro (shadow 'type)
|
||||
|
||||
(defparameter *semantic-engine-filenames*
|
||||
'("Utilities" "Markup" "RTF" "HTML" "GrammarSymbol" "Grammar" "Parser" "Metaparser" "Lexer" "Calculus" "CalculusMarkup"
|
||||
";JS20;Parser" ";JS20;Lexer" ";JS20;RegExp" #|"JSECMA;Lexer" "JSECMA;Parser"|# ))
|
||||
'("Utilities" "Markup" "RTF" "HTML" "GrammarSymbol" "Grammar" "Parser" "Metaparser" "Lexer" "Calculus" "CalculusMarkup"))
|
||||
|
||||
(defparameter *semantics-filenames*
|
||||
'("JS20/Parser" "JS20/Lexer" "JS20/RegExp" #|"JSECMA/Lexer" "JSECMA/Parser"|# ))
|
||||
|
||||
(defparameter *semantic-engine-directory*
|
||||
(make-pathname
|
||||
:directory (pathname-directory (truename *loading-file-source-file*))))
|
||||
:directory (pathname-directory #-mcl *load-truename*
|
||||
#+mcl (truename *loading-file-source-file*))))
|
||||
|
||||
|
||||
;;; Convert a filename string possibly containing slashes into a Lisp relative pathname.
|
||||
(defun filename-to-relative-pathname (filename)
|
||||
(let ((directories nil))
|
||||
(loop
|
||||
(let ((slash (position #\/ filename)))
|
||||
(if slash
|
||||
(progn
|
||||
(push (subseq filename 0 slash) directories)
|
||||
(setq filename (subseq filename (1+ slash))))
|
||||
(return (if directories
|
||||
(make-pathname :directory (cons ':relative (nreverse directories)) :name filename)
|
||||
filename)))))))
|
||||
|
||||
|
||||
;;; Convert a filename string possibly containing slashes relative to *semantic-engine-directory*
|
||||
;;; into a Lisp absolute pathname.
|
||||
(defun filename-to-semantic-engine-pathname (filename)
|
||||
(merge-pathnames (filename-to-relative-pathname filename) *semantic-engine-directory*))
|
||||
|
||||
|
||||
(defun operate-on-files (f files &rest options)
|
||||
(with-compilation-unit ()
|
||||
(dolist (filename files)
|
||||
(apply f (filename-to-semantic-engine-pathname filename) :verbose t options))))
|
||||
|
||||
(defun compile-semantic-engine ()
|
||||
(operate-on-files #'compile-file *semantic-engine-filenames* :load t))
|
||||
|
||||
(defun load-semantic-engine ()
|
||||
(dolist (filename *semantic-engine-filenames*)
|
||||
(let ((pathname (merge-pathnames filename *semantic-engine-directory*)))
|
||||
(load pathname :verbose t))))
|
||||
(operate-on-files #-allegro #'load #+allegro #'load-compiled *semantic-engine-filenames*))
|
||||
|
||||
(defun load-semantics ()
|
||||
(operate-on-files #'load *semantics-filenames*))
|
||||
|
||||
|
||||
(defmacro with-local-output ((stream filename) &body body)
|
||||
`(with-open-file (,stream (merge-pathnames ,filename *semantic-engine-directory*)
|
||||
`(with-open-file (,stream (filename-to-semantic-engine-pathname ,filename)
|
||||
:direction :output
|
||||
:if-exists :supersede)
|
||||
,@body))
|
||||
|
||||
|
||||
(load-semantic-engine)
|
||||
(load-semantics)
|
||||
|
|
|
|||
|
|
@ -225,14 +225,14 @@
|
|||
(substitute-soft-breaks
|
||||
tree
|
||||
#'(lambda (soft-break)
|
||||
(list (make-string (soft-break-width soft-break) :initial-element #\space :element-type 'base-character)))))
|
||||
(list (make-string (soft-break-width soft-break) :initial-element #\space :element-type #-mcl 'character #+mcl 'base-character)))))
|
||||
|
||||
|
||||
; Return a freshly consed markup list for a hard line break followed by indent spaces.
|
||||
(defun hard-break-markup (indent)
|
||||
(if (zerop indent)
|
||||
(list ':new-line)
|
||||
(list ':new-line (make-string indent :initial-element #\space :element-type 'base-character))))
|
||||
(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
|
||||
|
|
@ -600,7 +600,7 @@
|
|||
; The string should contain only letters, dashes, and numbers.
|
||||
(defun string-to-mixed-case (string &optional capitalize)
|
||||
(let* ((length (length string))
|
||||
(dst-string (make-array length :element-type 'base-character :fill-pointer 0)))
|
||||
(dst-string (make-array length :element-type #-mcl 'character #+mcl 'base-character :fill-pointer 0)))
|
||||
(dotimes (i length)
|
||||
(let ((char (char string i)))
|
||||
(if (eql char #\-)
|
||||
|
|
|
|||
|
|
@ -355,8 +355,8 @@
|
|||
; (an output stream), dividing the text as specified by dynamically scoped calls
|
||||
; to break-line. Return the text as a base-string.
|
||||
(defun write-limited-lines (emitter)
|
||||
(let ((limited-stream (make-string-output-stream :element-type 'base-character))
|
||||
(*current-limited-lines* (make-string-output-stream :element-type 'base-character))
|
||||
(let ((limited-stream (make-string-output-stream :element-type #-mcl 'character #+mcl 'base-character))
|
||||
(*current-limited-lines* (make-string-output-stream :element-type #-mcl 'character #+mcl 'base-character))
|
||||
(*current-limited-lines-non-empty* nil)
|
||||
(*current-limited-position* 0))
|
||||
(funcall emitter limited-stream)
|
||||
|
|
@ -525,7 +525,7 @@
|
|||
; Read RTF from the text file with the given name (relative to the
|
||||
; local directory) and return it in list form.
|
||||
(defun read-rtf-from-local-file (filename)
|
||||
(with-open-file (stream (merge-pathnames filename *semantic-engine-directory*)
|
||||
(with-open-file (stream (filename-to-semantic-engine-pathname filename)
|
||||
:direction :input)
|
||||
(read-rtf stream)))
|
||||
|
||||
|
|
@ -543,7 +543,7 @@
|
|||
(let ((i (position-if #'(lambda (char) (member char *rtf-special*)) string)))
|
||||
(if i
|
||||
(let* ((string-length (length string))
|
||||
(result-string (make-array string-length :element-type 'base-character :adjustable t :fill-pointer i)))
|
||||
(result-string (make-array string-length :element-type #-mcl 'character #+mcl 'base-character :adjustable t :fill-pointer i)))
|
||||
(replace result-string string)
|
||||
(do ((i i (1+ i)))
|
||||
((= i string-length))
|
||||
|
|
@ -632,7 +632,7 @@
|
|||
; Write RTF to the text file with the given name (relative to the
|
||||
; local directory).
|
||||
(defun write-rtf-to-local-file (filename rtf)
|
||||
(with-open-file (stream (merge-pathnames filename *semantic-engine-directory*)
|
||||
(with-open-file (stream (filename-to-semantic-engine-pathname filename)
|
||||
:direction :output
|
||||
:if-exists :supersede
|
||||
#+mcl :external-format #+mcl "RTF "
|
||||
|
|
|
|||
|
|
@ -45,13 +45,13 @@
|
|||
|
||||
#|
|
||||
(depict-rtf-to-local-file
|
||||
";Test;BaseExampleSemantics.rtf"
|
||||
"Test/BaseExampleSemantics.rtf"
|
||||
"Base Example Semantics"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *bew*)))
|
||||
|
||||
(depict-html-to-local-file
|
||||
";Test;BaseExampleSemantics.html"
|
||||
"Test/BaseExampleSemantics.html"
|
||||
"Base Example Semantics"
|
||||
t
|
||||
#'(lambda (html-stream)
|
||||
|
|
|
|||
|
|
@ -51,19 +51,19 @@
|
|||
|
||||
#|
|
||||
(depict-rtf-to-local-file
|
||||
";Test;ConstraintTestGrammar.rtf"
|
||||
"Test/ConstraintTestGrammar.rtf"
|
||||
"Constraint Test Grammar"
|
||||
#'(lambda (markup-stream)
|
||||
(depict-world-commands markup-stream *ctw* :visible-semantics nil)))
|
||||
|
||||
(depict-html-to-local-file
|
||||
";Test;ConstraintTestGrammar.html"
|
||||
"Test/ConstraintTestGrammar.html"
|
||||
"Constraint Test Grammar"
|
||||
t
|
||||
#'(lambda (markup-stream)
|
||||
(depict-world-commands markup-stream *ctw* :visible-semantics nil)))
|
||||
|
||||
(with-local-output (s ";Test;ConstraintTestGrammar.txt") (print-grammar *ctg* s))
|
||||
(with-local-output (s "Test/ConstraintTestGrammar.txt") (print-grammar *ctg* s))
|
||||
|
||||
(pprint (parse *ctg* #'identity '(begin letter letter letter digit end)))
|
||||
|#
|
||||
|
|
|
|||
|
|
@ -20,13 +20,13 @@
|
|||
|
||||
#|
|
||||
(depict-rtf-to-local-file
|
||||
";Test;StandardFunctionSemantics.rtf"
|
||||
"Test/StandardFunctionSemantics.rtf"
|
||||
"Standard Function Semantics"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *sfw*)))
|
||||
|
||||
(depict-html-to-local-file
|
||||
";Test;StandardFunctionSemantics.html"
|
||||
"Test/StandardFunctionSemantics.html"
|
||||
"Standard Function Semantics"
|
||||
t
|
||||
#'(lambda (html-stream)
|
||||
|
|
|
|||
|
|
@ -33,13 +33,13 @@
|
|||
|
||||
#|
|
||||
(depict-rtf-to-local-file
|
||||
";Test;ThrowCatchSemantics.rtf"
|
||||
"Test/ThrowCatchSemantics.rtf"
|
||||
"Base Example Semantics"
|
||||
#'(lambda (rtf-stream)
|
||||
(depict-world-commands rtf-stream *tcw*)))
|
||||
|
||||
(depict-html-to-local-file
|
||||
";Test;ThrowCatchSemantics.html"
|
||||
"Test/ThrowCatchSemantics.html"
|
||||
"Base Example Semantics"
|
||||
t
|
||||
#'(lambda (html-stream)
|
||||
|
|
|
|||
|
|
@ -155,7 +155,8 @@
|
|||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; VALUE ASSERTS
|
||||
|
||||
(defconstant *value-asserts* t)
|
||||
(eval-when (:compile-toplevel :load-toplevel)
|
||||
(defconstant *value-asserts* t))
|
||||
|
||||
; Assert that (test value) returns non-nil. Return value.
|
||||
(defmacro assert-value (value test &rest format-and-parameters)
|
||||
|
|
|
|||
Загрузка…
Ссылка в новой задаче