зеркало из https://github.com/mozilla/gecko-dev.git
853 строки
47 KiB
Common Lisp
853 строки
47 KiB
Common Lisp
;;; The contents of this file are subject to the Netscape Public License
|
|
;;; Version 1.0 (the "NPL"); you may not use this file except in
|
|
;;; compliance with the NPL. You may obtain a copy of the NPL at
|
|
;;; http://www.mozilla.org/NPL/
|
|
;;;
|
|
;;; Software distributed under the NPL is distributed on an "AS IS" basis,
|
|
;;; WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
|
|
;;; for the specific language governing rights and limitations under the
|
|
;;; NPL.
|
|
;;;
|
|
;;; The Initial Developer of this code under the NPL is Netscape
|
|
;;; Communications Corporation. Portions created by Netscape are
|
|
;;; Copyright (C) 1998 Netscape Communications Corporation. All Rights
|
|
;;; Reserved.
|
|
|
|
;;;
|
|
;;; ECMAScript sample grammar portions
|
|
;;;
|
|
;;; Waldemar Horwat (waldemar@netscape.com)
|
|
;;;
|
|
|
|
(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 (integer-to-rational 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 void-or-exception))))
|
|
|
|
(%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 double-or-exception))
|
|
(object-value (bottom double-or-exception))))
|
|
|
|
(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-or-exception))
|
|
((string-value s string) (oneof normal s))
|
|
(object-value (bottom string-or-exception))))
|
|
|
|
(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 object-or-exception))
|
|
(double-value (bottom object-or-exception))
|
|
(string-value (bottom object-or-exception))
|
|
((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 reference-or-exception))
|
|
|
|
(%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 (function-reference reference ((eval :lvalue) e))
|
|
(letexc (function value (reference-get-value function-reference))
|
|
(letexc (arguments (vector value) ((eval :arguments) e))
|
|
(let ((this object-or-null
|
|
(case function-reference
|
|
(((value-reference virtual-reference)) (oneof null-object-or-null))
|
|
((place-reference p place) (oneof object-object-or-null (& base p))))))
|
|
(call-object function 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 (function value ((eval :member-expression) e))
|
|
(letexc (arguments (vector value) ((eval :arguments) e))
|
|
(call-object function (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 (function value) (this object-or-null) (arguments (vector value))) reference-or-exception
|
|
(case function
|
|
(((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 (first left)))
|
|
(right-char-code integer (character-to-code (first right))))
|
|
(if (< left-char-code right-char-code)
|
|
less
|
|
(if (> left-char-code right-char-code)
|
|
greater
|
|
(compare-strings (rest left) (rest right) 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)
|
|
(lambda ((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
|
|
"ECMAGrammar.rtf"
|
|
#'(lambda (rtf-stream)
|
|
(depict-world-commands rtf-stream *gw*)))
|
|
|
|
(depict-html-to-local-file
|
|
"ECMAGrammar.html"
|
|
#'(lambda (rtf-stream)
|
|
(depict-world-commands rtf-stream *gw*))
|
|
"ECMA Grammar")
|
|
|
|
(with-local-output (s "ECMAGrammar.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'")
|
|
|#
|