diff --git a/js/semantics/GrammarSymbol.lisp b/js/semantics/GrammarSymbol.lisp index 615790c9fee..b2af8e1c02d 100644 --- a/js/semantics/GrammarSymbol.lisp +++ b/js/semantics/GrammarSymbol.lisp @@ -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 diff --git a/js/semantics/HTML.lisp b/js/semantics/HTML.lisp index b6e9f22bb86..1567388149a 100644 --- a/js/semantics/HTML.lisp +++ b/js/semantics/HTML.lisp @@ -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") diff --git a/js/semantics/JS14/Parser.lisp b/js/semantics/JS14/Parser.lisp index 7da33bc3f0c..e69de29bb2d 100644 --- a/js/semantics/JS14/Parser.lisp +++ b/js/semantics/JS14/Parser.lisp @@ -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)) -|# diff --git a/js/semantics/JS20/Lexer.lisp b/js/semantics/JS20/Lexer.lisp index 942af7ca078..cb9cfd24c89 100644 --- a/js/semantics/JS20/Lexer.lisp +++ b/js/semantics/JS20/Lexer.lisp @@ -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) |# diff --git a/js/semantics/JS20/Parser.lisp b/js/semantics/JS20/Parser.lisp index 8a1cefd6510..e4659ed14cb 100644 --- a/js/semantics/JS20/Parser.lisp +++ b/js/semantics/JS20/Parser.lisp @@ -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*)) diff --git a/js/semantics/JS20/RegExp.lisp b/js/semantics/JS20/RegExp.lisp index 34886aa95f9..a5e4a642b85 100644 --- a/js/semantics/JS20/RegExp.lisp +++ b/js/semantics/JS20/RegExp.lisp @@ -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) diff --git a/js/semantics/JSECMA/Lexer.lisp b/js/semantics/JSECMA/Lexer.lisp index 8b242f5e175..e69de29bb2d 100644 --- a/js/semantics/JSECMA/Lexer.lisp +++ b/js/semantics/JSECMA/Lexer.lisp @@ -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 - -;;; -;;; 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)) - - diff --git a/js/semantics/JSECMA/Parser.lisp b/js/semantics/JSECMA/Parser.lisp index bbb8c15bc98..e69de29bb2d 100644 --- a/js/semantics/JSECMA/Parser.lisp +++ b/js/semantics/JSECMA/Parser.lisp @@ -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 - -;;; -;;; 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'") -|# diff --git a/js/semantics/Main.lisp b/js/semantics/Main.lisp index ecbe6c05a17..a4f12decaaf 100644 --- a/js/semantics/Main.lisp +++ b/js/semantics/Main.lisp @@ -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) diff --git a/js/semantics/Markup.lisp b/js/semantics/Markup.lisp index 37ba99e5035..cc0d7975f1d 100644 --- a/js/semantics/Markup.lisp +++ b/js/semantics/Markup.lisp @@ -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 #\-) diff --git a/js/semantics/RTF.lisp b/js/semantics/RTF.lisp index f2624799a31..bd118ece7b4 100644 --- a/js/semantics/RTF.lisp +++ b/js/semantics/RTF.lisp @@ -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 " diff --git a/js/semantics/Test/BaseExample.lisp b/js/semantics/Test/BaseExample.lisp index 996f09ebd82..e69de29bb2d 100644 --- a/js/semantics/Test/BaseExample.lisp +++ b/js/semantics/Test/BaseExample.lisp @@ -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*)) diff --git a/js/semantics/Test/ConstraintTest.lisp b/js/semantics/Test/ConstraintTest.lisp index 8568d961f6e..e69de29bb2d 100644 --- a/js/semantics/Test/ConstraintTest.lisp +++ b/js/semantics/Test/ConstraintTest.lisp @@ -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 - -;;; -;;; 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*)) diff --git a/js/semantics/Test/StandardFunction.lisp b/js/semantics/Test/StandardFunction.lisp index 2b63cc624da..550d7304bfc 100644 --- a/js/semantics/Test/StandardFunction.lisp +++ b/js/semantics/Test/StandardFunction.lisp @@ -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) diff --git a/js/semantics/Test/ThrowCatch.lisp b/js/semantics/Test/ThrowCatch.lisp index 982665d14e7..e69de29bb2d 100644 --- a/js/semantics/Test/ThrowCatch.lisp +++ b/js/semantics/Test/ThrowCatch.lisp @@ -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*)) diff --git a/js/semantics/Utilities.lisp b/js/semantics/Utilities.lisp index a0550813260..cf2a37ea58a 100644 --- a/js/semantics/Utilities.lisp +++ b/js/semantics/Utilities.lisp @@ -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) diff --git a/js2/semantics/GrammarSymbol.lisp b/js2/semantics/GrammarSymbol.lisp index 615790c9fee..b2af8e1c02d 100644 --- a/js2/semantics/GrammarSymbol.lisp +++ b/js2/semantics/GrammarSymbol.lisp @@ -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 diff --git a/js2/semantics/HTML.lisp b/js2/semantics/HTML.lisp index b6e9f22bb86..1567388149a 100644 --- a/js2/semantics/HTML.lisp +++ b/js2/semantics/HTML.lisp @@ -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") diff --git a/js2/semantics/JS14/Parser.lisp b/js2/semantics/JS14/Parser.lisp index 7da33bc3f0c..d0aa2692c16 100644 --- a/js2/semantics/JS14/Parser.lisp +++ b/js2/semantics/JS14/Parser.lisp @@ -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)) |# diff --git a/js2/semantics/JS20/Lexer.lisp b/js2/semantics/JS20/Lexer.lisp index 942af7ca078..cb9cfd24c89 100644 --- a/js2/semantics/JS20/Lexer.lisp +++ b/js2/semantics/JS20/Lexer.lisp @@ -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) |# diff --git a/js2/semantics/JS20/Parser.lisp b/js2/semantics/JS20/Parser.lisp index 8a1cefd6510..e4659ed14cb 100644 --- a/js2/semantics/JS20/Parser.lisp +++ b/js2/semantics/JS20/Parser.lisp @@ -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*)) diff --git a/js2/semantics/JS20/RegExp.lisp b/js2/semantics/JS20/RegExp.lisp index 34886aa95f9..a5e4a642b85 100644 --- a/js2/semantics/JS20/RegExp.lisp +++ b/js2/semantics/JS20/RegExp.lisp @@ -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) diff --git a/js2/semantics/JSECMA/Lexer.lisp b/js2/semantics/JSECMA/Lexer.lisp index 8b242f5e175..a1e62985762 100644 --- a/js2/semantics/JSECMA/Lexer.lisp +++ b/js2/semantics/JSECMA/Lexer.lisp @@ -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) diff --git a/js2/semantics/JSECMA/Parser.lisp b/js2/semantics/JSECMA/Parser.lisp index bbb8c15bc98..65265b01c20 100644 --- a/js2/semantics/JSECMA/Parser.lisp +++ b/js2/semantics/JSECMA/Parser.lisp @@ -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')") diff --git a/js2/semantics/Main.lisp b/js2/semantics/Main.lisp index ecbe6c05a17..a4f12decaaf 100644 --- a/js2/semantics/Main.lisp +++ b/js2/semantics/Main.lisp @@ -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) diff --git a/js2/semantics/Markup.lisp b/js2/semantics/Markup.lisp index 37ba99e5035..cc0d7975f1d 100644 --- a/js2/semantics/Markup.lisp +++ b/js2/semantics/Markup.lisp @@ -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 #\-) diff --git a/js2/semantics/RTF.lisp b/js2/semantics/RTF.lisp index f2624799a31..bd118ece7b4 100644 --- a/js2/semantics/RTF.lisp +++ b/js2/semantics/RTF.lisp @@ -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 " diff --git a/js2/semantics/Test/BaseExample.lisp b/js2/semantics/Test/BaseExample.lisp index 996f09ebd82..8a0741aa12f 100644 --- a/js2/semantics/Test/BaseExample.lisp +++ b/js2/semantics/Test/BaseExample.lisp @@ -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) diff --git a/js2/semantics/Test/ConstraintTest.lisp b/js2/semantics/Test/ConstraintTest.lisp index 8568d961f6e..a83934d6836 100644 --- a/js2/semantics/Test/ConstraintTest.lisp +++ b/js2/semantics/Test/ConstraintTest.lisp @@ -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))) |# diff --git a/js2/semantics/Test/StandardFunction.lisp b/js2/semantics/Test/StandardFunction.lisp index 2b63cc624da..550d7304bfc 100644 --- a/js2/semantics/Test/StandardFunction.lisp +++ b/js2/semantics/Test/StandardFunction.lisp @@ -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) diff --git a/js2/semantics/Test/ThrowCatch.lisp b/js2/semantics/Test/ThrowCatch.lisp index 982665d14e7..91e2653c6ca 100644 --- a/js2/semantics/Test/ThrowCatch.lisp +++ b/js2/semantics/Test/ThrowCatch.lisp @@ -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) diff --git a/js2/semantics/Utilities.lisp b/js2/semantics/Utilities.lisp index a0550813260..cf2a37ea58a 100644 --- a/js2/semantics/Utilities.lisp +++ b/js2/semantics/Utilities.lisp @@ -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)