gecko-dev/js2/semantics/JSECMA/Parser.lisp
1999-07-27 01:05:27 +00:00

855 lines
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 (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'")
|#