gecko-dev/js2/semantics/JS20/Parser.lisp

;;;
;;; JavaScript 2.0 parser
;;;
;;; Waldemar Horwat (waldemar@acm.org)
;;;

(declaim (optimize (debug 3)))

(defparameter *jw-source*
  '((line-grammar code-grammar :lr-1 :program)
    
    (%heading (1 :semantics) "Data Model")
    (%heading (2 :semantics) "Semantic Exceptions")
    
    (deftuple break (value object) (label label))
    (deftuple continue (value object) (label label))
    (deftuple return (value object))
    
    (deftype control-transfer (union break continue return))
    (deftype semantic-exception (union object control-transfer))
    
    (%heading (2 :semantics) "Extended integers and rationals")
    
    (deftag +zero)
    (deftag -zero)
    (deftag +infinity)
    (deftag -infinity)
    (deftag nan)
    (deftype extended-rational (union (exclude-zero rational) (tag +zero -zero +infinity -infinity nan)))
    (deftype extended-integer (union integer (tag +infinity -infinity nan)))
    (? hide
      (deftag syntax-error))
    
    
    (%heading (2 :semantics) "Objects")
    (deftag none)
    (deftag ok)
    (deftag reject)
    
    (deftype object (union undefined null boolean long u-long float32 float64 char16 string namespace compound-attribute
                           class simple-instance method-closure date reg-exp package))
    (deftype primitive-object (union undefined null boolean long u-long float32 float64 char16 string))
    (deftype nonprimitive-object (union namespace compound-attribute class simple-instance method-closure date reg-exp package))
    (deftype binding-object (union class simple-instance reg-exp date package))
    
    (deftype object-opt (union object (tag none)))
    (deftype boolean-opt (union boolean (tag none)))
    (deftype integer-opt (union integer (tag none)))
    
    
    (%heading (3 :semantics) "Undefined")
    (deftag undefined)
    (deftype undefined (tag undefined))
    
    
    (%heading (3 :semantics) "Null")
    (deftag null)
    (deftype null (tag null))
    
    
    (%heading (3 :semantics) "Strings")
    (deftype string-opt (union string (tag none)))
    
    
    (%heading (3 :semantics) "Namespaces")
    (defrecord namespace
      (name string))
    
    
    (%heading (4 :semantics) "Qualified Names")
    (deftuple qualified-name (namespace namespace) (id string))
    (definfix qualified-name ("::") ns id)
    
    (deftype multiname (list-set qualified-name))
    
    
    (%heading (3 :semantics) "Attributes")
    (deftag static)
    (deftag virtual)
    (deftag final)
    (deftype property-category (tag none static virtual final))
    
    (deftype override-modifier (tag none true false undefined))
    
    (deftuple compound-attribute
      (namespaces (list-set namespace))
      (explicit boolean)
      (enumerable boolean)
      (dynamic boolean)
      (category property-category)
      (override-mod override-modifier)
      (prototype boolean)
      (unused boolean))
    
    (deftype attribute (union boolean namespace compound-attribute))
    (deftype attribute-opt-not-false (union (tag none true) namespace compound-attribute))
    
    
    (%heading (3 :semantics) "Classes")
    (defrecord class
      (local-bindings (list-set local-binding) :var)
      (instance-properties (list-set instance-property) :var)
      (super class-opt)
      (prototype object-opt :opt-const)
      (complete boolean :var)
      (name string)
      (typeof-string string)
      (private-namespace namespace :opt-const)
      (dynamic boolean)
      (final boolean)
      (default-value object-opt)
      (default-hint hint :opt-const)
      (has-property (-> (object class object boolean phase) boolean))
      (bracket-read (-> (object class (vector object) boolean phase) object-opt))
      (bracket-write (-> (object class (vector object) object boolean (tag run)) (tag none ok)))
      (bracket-delete (-> (object class (vector object) (tag run)) boolean-opt))
      (read (-> (object class multiname environment-opt boolean phase) object-opt))
      (write (-> (object class multiname environment-opt object boolean (tag run)) (tag none ok)))
      (delete (-> (object class multiname environment-opt (tag run)) boolean-opt))
      (enumerate (-> (object) (list-set object)))
      (call (-> (object class (vector object) phase) object))
      (construct (-> (class (vector object) phase) object))
      (init (union (-> (simple-instance (vector object) (tag run)) void) (tag none)) :var)
      (is (-> (object class) boolean))
      (coerce (-> (object class) object-opt)))
    (deftype class-opt (union class (tag none)))
    
    
    (%heading (3 :semantics) "Simple Instances")
    (defrecord simple-instance
      (local-bindings (list-set local-binding) :var)
      (archetype object-opt :opt-const)
      (sealed boolean :var)
      (type class)
      (slots (list-set slot))
      (call (union (-> (object simple-instance (vector object) phase) object) (tag none)))
      (construct (union (-> (simple-instance (vector object) phase) object) (tag none)))
      (env environment-opt))
    
    
    (%heading (4 :semantics) "Slots")
    (defrecord slot
      (id instance-variable)
      (value object-opt :var))
    
    
    (%heading (3 :semantics) "Uninstantiated Functions")
    (defrecord uninstantiated-function
      (type class)
      (length integer)
      (call (union (-> (object simple-instance (vector object) phase) object) (tag none)))
      (construct (union (-> (simple-instance (vector object) phase) object) (tag none)))
      (instantiations (list-set simple-instance) :var))
    
    
    (%heading (3 :semantics) "Method Closures")
    (deftuple method-closure
      (this object)
      (method instance-method)
      (slots (list-set slot)))
    
    
    (%heading (3 :semantics) "Dates")
    (defrecord date
      (local-bindings (list-set local-binding) :var)
      (archetype object-opt)
      (sealed boolean :var)
      (time-value integer))
    
    
    (%heading (3 :semantics) "Regular Expressions")
    (defrecord reg-exp
      (local-bindings (list-set local-binding) :var)
      (archetype object-opt)
      (sealed boolean :var)
      (source string)
      (last-index integer)
      (global boolean)
      (ignore-case boolean)
      (multiline boolean))
    
   
    (%heading (3 :semantics) "Packages")
    (defrecord package
      (local-bindings (list-set local-binding) :var)
      (archetype object-opt)
      (name string)
      (initialize (union (-> () void) (tag none busy)) :var)
      (sealed boolean :var)
      (internal-namespace namespace))
    
    
    (%heading (2 :semantics) "Objects with Limits")
    (%text :comment (:label limited-instance instance) " must be an instance of one of "
           (:label limited-instance limit) :apostrophe "s descendants.")
    (deftuple limited-instance
      (instance object)
      (limit class))
    
    (deftype obj-optional-limit (union object limited-instance))
    
    
    (%heading (2 :semantics) "References")
    (deftuple lexical-reference
      (env environment)
      (variable-multiname multiname)
      (strict boolean))
    
    (deftuple dot-reference
      (base object)
      (limit class)
      (multiname multiname))
    
    (deftuple bracket-reference
      (base object)
      (limit class)
      (args (vector object)))
    
    (deftype reference (union lexical-reference dot-reference bracket-reference))
    (deftype obj-or-ref (union object reference))
    
    
    (%heading (2 :semantics) "Modes of expression evaluation")
    (deftag compile)
    (deftag run)
    (deftype phase (tag compile run))
    
    
    (%heading (2 :semantics) "Contexts")
    (defrecord context
      (strict boolean :var)
      (open-namespaces (list-set namespace) :var))
    
    
    (%heading (2 :semantics) "Labels")
    (deftag default)
    (deftype label (union string (tag default)))
    
    (deftuple jump-targets
      (break-targets (list-set label))
      (continue-targets (list-set label)))
    
    
    (%heading (2 :semantics) "Function Support")
    (deftag normal)
    (deftag get)
    (deftag set)
    (deftype handling (tag normal get set))
    
    (deftag plain-function)
    (deftag unchecked-function)
    (deftag prototype-function)
    (deftag instance-function)
    (deftag constructor-function)
    (deftype static-function-kind (tag plain-function unchecked-function prototype-function))
    (deftype function-kind (tag plain-function unchecked-function prototype-function instance-function constructor-function))
    
    
    (%heading (2 :semantics) "Environments")
    (%text :comment "An " (:type environment) " is a list of two or more frames. Each frame corresponds to a scope. "
           "More specific frames are listed first" :m-dash "each frame" :apostrophe "s scope is directly contained in the following frame"
           :apostrophe "s scope. The last frame is always a " (:type package)
           ". A " (:type with-frame) " is always preceded by a " (:type local-frame) ", so the first frame is never a " (:type with-frame) ".")
    (deftype environment (vector frame))
    (deftype environment-opt (union environment (tag none)))
    (deftype frame (union non-with-frame with-frame))
    (deftype non-with-frame (union package parameter-frame class local-frame))
    
    (defrecord parameter-frame
      (local-bindings (list-set local-binding) :var)
      (kind function-kind)
      (handling handling)
      (calls-superconstructor boolean :var)
      (superconstructor-called boolean :var)
      (this object-opt)
      (parameters (vector parameter) :opt-var)
      (rest variable-opt :opt-var)
      (return-type class :opt-const))
    (deftype parameter-frame-opt (union parameter-frame (tag none)))
     
    (deftuple parameter
      (var (union variable dynamic-var))
      (default object-opt))
    
    (defrecord local-frame
      (local-bindings (list-set local-binding) :var))
    
    (defrecord with-frame
      (value object-opt))
    
    
    (%heading (3 :semantics) "Properties")
    (deftag read)
    (deftag write)
    (deftag read-write)
    (deftype access (tag read write))
    (deftype access-set (tag read write read-write))
    
    
    (deftuple local-binding 
      (qname qualified-name)
      (accesses access-set)
      (explicit boolean)
      (enumerable boolean)
      (content singleton-property))
    
    
    (deftag forbidden)
    (deftype singleton-property (union (tag forbidden) variable dynamic-var getter setter))
    (deftype singleton-property-opt (union singleton-property (tag none)))
   
    (deftype variable-value (union (tag none) object uninstantiated-function))
    
    (deftag busy)
    (deftype initializer (-> (environment phase) object))
    (deftype initializer-opt (union initializer (tag none)))
    
    (defrecord variable
      (type class :opt-const)
      (value variable-value :var)
      (immutable boolean)
      (setup (union (-> () class-opt) (tag none busy)) :var)
      (initializer (union initializer (tag none busy)) :var)
      (initializer-env environment :opt-const))
    (deftype variable-opt (union variable (tag none)))
    
    (defrecord dynamic-var
      (value (union object uninstantiated-function) :var)
      (sealed boolean :var))
    
    (defrecord getter
      (call (-> (environment phase) object))
      (env environment-opt))
    
    (defrecord setter
      (call (-> (object environment phase) void))
      (env environment-opt))
    
    
    (deftype instance-property (union instance-variable instance-method instance-getter instance-setter))
    (deftype instance-property-opt (union instance-property (tag none)))
    
    (defrecord instance-variable
      (multiname multiname :opt-const)
      (final boolean)
      (enumerable boolean :opt-const)
      (type class :opt-const)
      (default-value object-opt :opt-const)
      (immutable boolean))
    (deftype instance-variable-opt (union instance-variable (tag none)))
    
    (defrecord instance-method
      (multiname multiname :opt-const)
      (final boolean)
      (enumerable boolean :opt-const)
      (signature parameter-frame :opt-const)
      (length integer)
      (call (-> (object (vector object) phase) object)))
    
    (defrecord instance-getter
      (multiname multiname :opt-const)
      (final boolean)
      (enumerable boolean :opt-const)
      (signature parameter-frame :opt-const)
      (call (-> (object phase) object)))
    
    (defrecord instance-setter
      (multiname multiname :opt-const)
      (final boolean)
      (enumerable boolean :opt-const)
      (signature parameter-frame :opt-const)
      (call (-> (object object phase) void)))
    
    
    (deftype property-opt (union singleton-property instance-property (tag none)))
    
    
    (%heading (2 :semantics) "Miscellaneous")
    (deftag hint-string)
    (deftag hint-number)
    (deftype hint (tag hint-string hint-number))
    (deftype hint-opt (union hint (tag none)))
    
    (deftag less)
    (deftag equal)
    (deftag greater)
    (deftag unordered)
    (deftype order (tag less equal greater unordered))
    
    
    (%heading (1 :semantics) "Data Operations")
    (%heading (2 :semantics) "Numeric Utilities")
    
    (%text :comment (:global-call unsigned-wrap32 i) " returns " (:local i) " converted to a value between 0 and 2" (:superscript "32") :minus
           "1 inclusive, wrapping around modulo 2" (:superscript "32") " if necessary.")
    (define (unsigned-wrap32 (i integer)) (integer-range 0 (- (expt 2 32) 1))
      (return (bitwise-and i (hex #xFFFFFFFF))))
    
    (%text :comment (:global-call signed-wrap32 i) " returns " (:local i) " converted to a value between " :minus "2" (:superscript "31")
           " and 2" (:superscript "31") :minus "1 inclusive, wrapping around modulo 2" (:superscript "32") " if necessary.")
    (define (signed-wrap32 (i integer)) (integer-range (neg (expt 2 31)) (- (expt 2 31) 1))
      (var j integer (bitwise-and i (hex #xFFFFFFFF)))
      (when (>= j (expt 2 31))
        (<- j (- j (expt 2 32))))
      (return j))
    
    (%text :comment (:global-call unsigned-wrap64 i) " returns " (:local i) " converted to a value between 0 and 2" (:superscript "64") :minus
           "1 inclusive, wrapping around modulo 2" (:superscript "64") " if necessary.")
    (define (unsigned-wrap64 (i integer)) (integer-range 0 (- (expt 2 64) 1))
      (return (bitwise-and i (hex #xFFFFFFFFFFFFFFFF))))
    
    (%text :comment (:global-call signed-wrap64 i) " returns " (:local i) " converted to a value between " :minus "2" (:superscript "63")
           " and 2" (:superscript "63") :minus "1 inclusive, wrapping around modulo 2" (:superscript "64") " if necessary.")
    (define (signed-wrap64 (i integer)) (integer-range (neg (expt 2 63)) (- (expt 2 63) 1))
      (var j integer (bitwise-and i (hex #xFFFFFFFFFFFFFFFF)))
      (when (>= j (expt 2 63))
        (<- j (- j (expt 2 64))))
      (return j))
    
    #|
    (%text :comment (:global-call truncate-to-extended-integer x) " returns " (:local x) " converted to an integer by rounding towards zero. If " (:local x)
           " is an infinity or a NaN, the result is " (:tag +infinity) ", " (:tag -infinity) ", or " (:tag nan) ", as appropriate.")
    (define (truncate-to-extended-integer (x general-number)) extended-integer
      (case x
        (:select (tag +infinity32 +infinity64) (return +infinity))
        (:select (tag -infinity32 -infinity64) (return -infinity))
        (:select (tag nan32 nan64) (return nan))
        (:narrow finite-float32 (return (truncate-finite-float32 x)))
        (:narrow finite-float64 (return (truncate-finite-float64 x)))
        (:narrow (union long u-long) (return (& value x)))))
    |#
    
    (%text :comment (:global-call truncate-to-integer x) " returns " (:local x) " converted to an integer by rounding towards zero. If " (:local x)
           " is an infinity or a NaN, the result is 0.")
    (define (truncate-to-integer (x general-number)) integer
      (case x
        (:select (tag nan32 nan64 +infinity32 +infinity64 -infinity32 -infinity64) (return 0))
        (:narrow finite-float32 (return (truncate-finite-float32 x)))
        (:narrow finite-float64 (return (truncate-finite-float64 x)))
        (:narrow (union long u-long) (return (& value x)))))
    
    
    (%text :comment (:def-const limit integer) (:global-call pin-extended-integer i limit negative-from-end) " returns " (:local i) " pinned to the set "
           (:expr (range-set integer) (range-set-of-ranges integer 0 limit)) ", where " (:local limit) " is a nonnegative integer. If "
           (:local negative-from-end) " is " (:tag true)
           ", then negative values of " (:local i) " from " (:expr integer (neg limit)) " through " (:expr integer -1) " are treated as 0 through "
           (:expr integer (- limit 1)) " respectively.")
    (define (pin-extended-integer (i extended-integer) (limit integer) (negative-from-end boolean)) integer
      (case i
        (:select (tag nan) (throw-error -range-error))
        (:select (tag -infinity) (return 0))
        (:select (tag +infinity) (return limit))
        (:narrow integer
          (var j integer i)
          (when (> j limit)
            (<- j limit))
          (when (and negative-from-end (< j 0))
            (<- j (+ j limit)))
          (when (< j 0)
            (<- j 0))
          (assert (cascade integer 0 <= j <= limit))
          (return j))))

    
    (%text :comment (:global-call check-integer x) " returns " (:local x) " converted to an integer if its mathematical value is, in fact, an integer. "
           "If " (:local x) " is an infinity or a NaN or has a fractional part, the result is " (:tag none) ".")
    (define (check-integer (x general-number)) integer-opt
      (case x
        (:select (tag nan32 nan64 +infinity32 +infinity64 -infinity32 -infinity64) (return none))
        (:select (tag +zero32 +zero64 -zero32 -zero64) (return 0))
        (:narrow (union long u-long) (return (& value x)))
        (:narrow (union nonzero-finite-float32 nonzero-finite-float64)
          (const r rational (& value x))
          (rwhen (not-in r integer :narrow-false)
            (return none))
          (return r))))
    
    (%text :comment (:global-call integer-to-long i) " converts " (:local i) " to the first of the types " (:type long) ", " (:type u-long) ", or " (:type float64)
           " that can contain the value " (:local i) ". If necessary, the " (:type float64) " result may be rounded or converted to an infinity using the IEEE 754 "
           :left-double-quote "round to nearest" :right-double-quote " mode.")
    (define (integer-to-long (i integer)) general-number
      (cond
       ((cascade integer (neg (expt 2 63)) <= i <= (- (expt 2 63) 1))
        (return (new long i)))
       ((cascade integer (expt 2 63) <= i <= (- (expt 2 64) 1))
        (return (new u-long i)))
       (nil
        (return (real-to-float64 i)))))
    
    (%text :comment (:global-call integer-to-u-long i) " converts " (:local i) " to the first of the types " (:type u-long) ", " (:type long) ", or " (:type float64)
           " that can contain the value " (:local i) ". If necessary, the " (:type float64) " result may be rounded or converted to an infinity using the IEEE 754 "
           :left-double-quote "round to nearest" :right-double-quote " mode.")
    (define (integer-to-u-long (i integer)) general-number
      (cond
       ((cascade integer 0 <= i <= (- (expt 2 64) 1))
        (return (new u-long i)))
       ((cascade integer (neg (expt 2 63)) <= i <= -1)
        (return (new long i)))
       (nil
        (return (real-to-float64 i)))))
    
    (%text :comment (:global-call rational-to-long q) " converts " (:local q) " to one of the types " (:type long) ", " (:type u-long) ", or " (:type float64)
           ", whichever one can come the closest to representing the true value of " (:local q) ". If several of these types can come equally close to the value of "
           (:local q) ", then one of them is chosen according to the algorithm below.")
    (define (rational-to-long (q rational)) general-number
      (cond
       ((in q integer :narrow-true) (return (integer-to-long q)))
       ((<= (rat-abs q) (expt 2 53) rational) (return (real-to-float64 q)))
       ((or (< q (rat- (neg (expt 2 63)) (rat/ 1 2)) rational) (>= q (rat- (expt 2 64) (rat/ 1 2)) rational)) (return (real-to-float64 q)))
       (nil
        (/* (:def-const i integer) "Let " (:local i) " be the integer closest to " (:local q)
            ". If " (:local q) " is halfway between two integers, pick " (:local i) " so that it is even.")
        (var i integer (floor q))
        (var frac rational (rat- q i))
        (when (or (> frac (rat/ 1 2) rational) (and (= frac (rat/ 1 2) rational) (= (bitwise-and i 1) 1)))
          (<- i (+ i 1)))
        (*/)
        (assert (cascade integer (neg (expt 2 63)) <= i <= (- (expt 2 64) 1)))
        (if (< i (expt 2 63))
          (return (new long i))
          (return (new u-long i))))))
    
    (%text :comment (:global-call rational-to-u-long q) " converts " (:local q) " to one of the types " (:type u-long) ", " (:type long) ", or " (:type float64)
           ", whichever one can come the closest to representing the true value of " (:local q) ". If several of these types can come equally close to the value of "
           (:local q) ", then one of them is chosen according to the algorithm below.")
    (define (rational-to-u-long (q rational)) general-number
      (cond
       ((in q integer :narrow-true) (return (integer-to-u-long q)))
       ((<= (rat-abs q) (expt 2 53) rational) (return (real-to-float64 q)))
       ((or (< q (rat- (neg (expt 2 63)) (rat/ 1 2)) rational) (>= q (rat- (expt 2 64) (rat/ 1 2)) rational)) (return (real-to-float64 q)))
       (nil
        (/* (:def-const i integer) "Let " (:local i) " be the integer closest to " (:local q)
            ". If " (:local q) " is halfway between two integers, pick " (:local i) " so that it is even.")
        (var i integer (floor q))
        (var frac rational (rat- q i))
        (when (or (> frac (rat/ 1 2) rational) (and (= frac (rat/ 1 2) rational) (= (bitwise-and i 1) 1)))
          (<- i (+ i 1)))
        (*/)
        (assert (cascade integer (neg (expt 2 63)) <= i <= (- (expt 2 64) 1)))
        (if (>= i 0)
          (return (new u-long i))
          (return (new long i))))))
    
    
    (define (extended-rational-to-float32 (q extended-rational)) float32
      (case q
        (:narrow rational (return (real-to-float32 q)))
        (:select (tag +zero) (return +zero32))
        (:select (tag -zero) (return -zero32))
        (:select (tag +infinity) (return +infinity32))
        (:select (tag -infinity) (return -infinity32))
        (:select (tag nan) (return nan32))))
    
    
    (define (extended-rational-to-float64 (q extended-rational)) float64
      (case q
        (:narrow rational (return (real-to-float64 q)))
        (:select (tag +zero) (return +zero64))
        (:select (tag -zero) (return -zero64))
        (:select (tag +infinity) (return +infinity64))
        (:select (tag -infinity) (return -infinity64))
        (:select (tag nan) (return nan64))))
    
    
    (%text :comment (:global-call to-rational x) " returns the exact " (:type rational) " value of " (:local x) ".")
    (define (to-rational (x finite-general-number)) rational
      (case x
        (:select (tag +zero32 +zero64 -zero32 -zero64) (return 0))
        (:narrow (union nonzero-finite-float32 nonzero-finite-float64 long u-long) (return (& value x)))))
    
    (%text :comment (:global-call to-float32 x) " converts " (:local x) " to a " (:type float32) ", using the IEEE 754 "
           :left-double-quote "round to nearest" :right-double-quote " mode.")
    (define (to-float32 (x general-number)) float32
      (case x
        (:narrow (union long u-long) (return (real-to-float32 (& value x))))
        (:narrow float32 (return x))
        (:select (tag -infinity64) (return -infinity32))
        (:select (tag -zero64) (return -zero32))
        (:select (tag +zero64) (return +zero32))
        (:select (tag +infinity64) (return +infinity32))
        (:select (tag nan64) (return nan32))
        (:narrow nonzero-finite-float64 (return (real-to-float32 (& value x))))))
    
    (%text :comment (:global-call to-float64 x) " converts " (:local x) " to a " (:type float64) ", using the IEEE 754 "
           :left-double-quote "round to nearest" :right-double-quote " mode.")
    (define (to-float64 (x general-number)) float64
      (case x
        (:narrow (union long u-long) (return (real-to-float64 (& value x))))
        (:narrow float32 (return (float32-to-float64 x)))
        (:narrow float64 (return x))))
    
    
    (%text :comment (:global-call general-number-compare x y) " compares " (:local x) " with " (:local y) " using the IEEE 754 rules and returns "
           (:tag less) " if " (:local x) "<" (:local y) ", " (:tag equal) " if " (:local x) "=" (:local y) ", " (:tag greater) " if " (:local x) ">" (:local y)
           ", or " (:tag unordered) " if either " (:local x) " or " (:local y) " is a NaN. The comparison is done using the exact values of " (:local x) " and " (:local y)
           ", even if they have different types. Positive infinities compare equal to each other and greater than any other non-NaN values. Negative infinities compare "
           "equal to each other and less than any other non-NaN values. Positive and negative zeroes compare equal to each other.")
    (define (general-number-compare (x general-number) (y general-number)) order
      (cond
       ((or (in x (tag nan32 nan64) :narrow-false) (in y (tag nan32 nan64) :narrow-false))
        (return unordered))
       ((and (in x (tag +infinity32 +infinity64)) (in y (tag +infinity32 +infinity64)))
        (return equal))
       ((and (in x (tag -infinity32 -infinity64)) (in y (tag -infinity32 -infinity64)))
        (return equal))
       ((or (in x (tag +infinity32 +infinity64) :narrow-false) (in y (tag -infinity32 -infinity64) :narrow-false))
        (return greater))
       ((or (in x (tag -infinity32 -infinity64) :narrow-false) (in y (tag +infinity32 +infinity64) :narrow-false))
        (return less))
       (nil
        (const xr rational (to-rational x))
        (const yr rational (to-rational y))
        (cond
         ((< xr yr rational) (return less))
         ((> xr yr rational) (return greater))
         (nil (return equal))))))
    
    
    (%heading (2 :semantics) "Character Utilities")
    
    (define (integer-to-u-t-f16 (i (integer-range 0 (hex #x10FFFF)))) string
      (cond
       ((cascade integer 0 <= i <= (hex #xFFFF))
        (return (vector (integer-to-char16 i))))
       (nil
        (const j (integer-range 0 (hex #xFFFFF)) (- i (hex #x10000)))
        (const high char16 (integer-to-char16 (+ (hex #xD800) (bitwise-shift j -10))))
        (const low char16 (integer-to-char16 (+ (hex #xDC00) (bitwise-and j (hex #x3FF)))))
        (return (vector high low)))))
    
    
    (define (char21-to-u-t-f16 (ch char21)) string
      (return (integer-to-u-t-f16 (char21-to-integer ch))))
    
    
    (define (surrogate-pair-to-supplementary-char (h char16) (l char16)) supplementary-char
      (const code-point (integer-range (hex #x10000) (hex #x10FFFF))
        (+ (+ (hex #x10000) (* (- (char16-to-integer h) (hex #xD800)) (hex #x400))) (- (char16-to-integer l) (hex #xDC00))))
      (return (integer-to-supplementary-char code-point)))
    
    
    (define (string-to-u-t-f32 (s string)) (vector char21)
      (var i integer 0)
      (var result (vector char21) (vector-of char21))
      (while (/= i (length s))
        (var ch char21)
        (cond
         ((and (set-in (nth s i) (range-set-of-ranges char16 #?D800 #?DBFF)) (/= (+ i 1) (length s)) (set-in (nth s (+ i 1)) (range-set-of-ranges char16 #?DC00 #?DFFF)))
          (<- ch (surrogate-pair-to-supplementary-char (nth s i) (nth s (+ i 1))))
          (<- i (+ i 2)))
         (nil
          (<- ch (nth s i))
          (<- i (+ i 1))))
        (<- result (append result (vector ch))))
      (return result))
    
    
    (define (char-to-lower-full (ch char21)) string
      (/* (:keyword return) " " (:local ch) " converted to a lower case character using the Unicode full, locale-independent case mapping. "
          "A single character may be converted to multiple characters. If " (:local ch) " has no lower case equivalent, then the result is the string "
          (:expr string (char21-to-u-t-f16 ch)) ".")
      (cond
       ((in ch supplementary-char :narrow-both)
        (return (char21-to-u-t-f16 ch))) ;Don't worry for now about converting the case of these
       (nil (return (vector (lisp-call char-downcase (ch) char16))))))
    
    
    (define (char-to-lower-localized (ch char21)) string
      (/* (:keyword return) " " (:local ch) " converted to a lower case character using the Unicode full case mapping in the host environment" :apostrophe
          "s current locale. "
          "A single character may be converted to multiple characters. If " (:local ch) " has no lower case equivalent, then the result is the string "
          (:expr string (char21-to-u-t-f16 ch)) ".")
      (cond
       ((in ch supplementary-char :narrow-both)
        (return (char21-to-u-t-f16 ch))) ;Don't worry for now about converting the case of these
       (nil (return (vector (lisp-call char-downcase (ch) char16))))))
    
    
    (define (char-to-upper-full (ch char21)) string
      (/* (:keyword return) " " (:local ch) " converted to a upper case character using the Unicode full, locale-independent case mapping. "
          "A single character may be converted to multiple characters. If " (:local ch) " has no upper case equivalent, then the result is the string "
          (:expr string (char21-to-u-t-f16 ch)) ".")
      (cond
       ((in ch supplementary-char :narrow-both)
        (return (char21-to-u-t-f16 ch))) ;Don't worry for now about converting the case of these
       (nil (return (vector (lisp-call char-upcase (ch) char16))))))
    
    
    (define (char-to-upper-localized (ch char21)) string
      (/* (:keyword return) " " (:local ch) " converted to a upper case character using the Unicode full case mapping in the host environment" :apostrophe
          "s current locale. "
          "A single character may be converted to multiple characters. If " (:local ch) " has no upper case equivalent, then the result is the string "
          (:expr string (char21-to-u-t-f16 ch)) ".")
      (cond
       ((in ch supplementary-char :narrow-both)
        (return (char21-to-u-t-f16 ch))) ;Don't worry for now about converting the case of these
       (nil (return (vector (lisp-call char-downcase (ch) char16))))))
    
    
    (%heading (2 :semantics) "Object Utilities")
    (%heading (3 :semantics) "Object Class Inquiries")
    (%text :comment (:global-call object-type o) " returns an " (:type object) " " (:local o) :apostrophe "s most specific type. Although "
           (:global object-type) " is used internally throughout this specification, in order to allow one programmer-visible class to be implemented as an "
           "ensemble of implementation-specific classes, no way is provided for a user program to directly obtain the result of calling " (:global object-type)
           " on an object.")
    (define (object-type (o object)) class
      (case o
        (:select undefined (return -void))
        (:select null (return -null))
        (:select boolean (return -boolean))
        (:select long (return \#long))
        (:select u-long (return ulong))
        (:select float32 (return float))
        (:select float64 (return -number))
        (:select char16 (return char))
        (:select string (return -string))
        (:select namespace (return -namespace))
        (:select compound-attribute (return -attribute))
        (:select class (return -class))
        (:narrow simple-instance (return (& type o)))
        (:select method-closure (return -function))
        (:select date (return -date))
        (:select reg-exp (return -reg-exp))
        (:select package (return -package))))
    
    
    (%text :comment (:global-call is o c) " returns " (:tag true) " if " (:local o) " is an instance of class " (:local c) " or one of its subclasses.")
    (define (is (o object) (c class)) boolean
      (return ((& is c) o c)))
    
    
    (%text :comment (:global-call ordinary-is o c) " is the implementation of " (:global is) " for a native class unless specified otherwise in the class" :apostrophe
           "s definition. Host classes may either also use " (:global ordinary-is) " or define a different procedure to perform this test.")
    (define (ordinary-is (o object) (c class)) boolean
      (return (is-ancestor c (object-type o))))
    
    
    (%text :comment "Return an ordered list of class " (:local c) :apostrophe "s ancestors, including " (:local c) " itself.")
    (define (ancestors (c class)) (vector class)
      (const s class-opt (& super c))
      (if (in s (tag none) :narrow-false)
        (return (vector c))
        (return (append (ancestors s) (vector c)))))
    
    (%text :comment "Return " (:tag true) " if " (:local c) " is " (:local d) " or an ancestor of " (:local d) ".")
    (define (is-ancestor (c class) (d class)) boolean
      (cond
       ((= c d class) (return true))
       (nil (const s class-opt (& super d))
            (rwhen (in s (tag none) :narrow-false)
              (return false))
            (return (is-ancestor c s)))))

    #|
    (%text :comment "Return " (:tag true) " if " (:local c) " is an ancestor of " (:local d) " other than " (:local d) " itself.")
    (define (is-proper-ancestor (c class) (d class)) boolean
      (return (and (is-ancestor c d) (/= c d class))))
    |#
    
    
    (%heading (3 :semantics) "Object to Boolean Conversion")
    (%text :comment (:global-call object-to-boolean o) " returns " (:local o) " converted to a " (:global -boolean) ".")
    (define (object-to-boolean (o object)) boolean
      (case o
        (:select (union undefined null) (return false))
        (:narrow boolean (return o))
        (:narrow (union long u-long) (return (/= (& value o) 0)))
        (:narrow float32 (return (not-in o (tag +zero32 -zero32 nan32))))
        (:narrow float64 (return (not-in o (tag +zero64 -zero64 nan64))))
        (:narrow string (return (/= o "" string)))
        (:select (union char16 namespace compound-attribute class simple-instance method-closure date reg-exp package) (return true))))
    
    
    (%heading (3 :semantics) "Object to Primitive Conversion")
    (define (object-to-primitive (o object) (hint hint-opt) (phase phase)) primitive-object
      (rwhen (in o primitive-object :narrow-true)
        (return o))
      (const c class (object-type o))
      (var h hint)
      (if (in hint hint :narrow-true)
        (<- h hint)
        (<- h (&opt default-hint c)))
      (case h
        (:select (tag hint-string)
          (const to-string-method object-opt ((& read c) o c (list-set (new qualified-name public "toString")) none false phase))
          (when (not-in to-string-method (tag none) :narrow-true)
            (const r object (call o to-string-method (vector-of object) phase))
            (rwhen (in r primitive-object :narrow-true)
              (return r)))
          (const value-of-method object-opt ((& read c) o c (list-set (new qualified-name public "valueOf")) none false phase))
          (when (not-in value-of-method (tag none) :narrow-true)
            (const r object (call o value-of-method (vector-of object) phase))
            (rwhen (in r primitive-object :narrow-true)
              (return r))))
        (:select (tag hint-number)
          (const value-of-method object-opt ((& read c) o c (list-set (new qualified-name public "valueOf")) none false phase))
          (when (not-in value-of-method (tag none) :narrow-true)
            (const r object (call o value-of-method (vector-of object) phase))
            (rwhen (in r primitive-object :narrow-true)
              (return r)))
          (const to-string-method object-opt ((& read c) o c (list-set (new qualified-name public "toString")) none false phase))
          (when (not-in to-string-method (tag none) :narrow-true)
            (const r object (call o to-string-method (vector-of object) phase))
            (rwhen (in r primitive-object :narrow-true)
              (return r)))))
      (throw-error -type-error "cannot convert this object to a primitive"))
    
    
    (%heading (3 :semantics) "Object to Number Conversions")
    (%text :comment (:global-call object-to-general-number o phase) " returns " (:local o) " converted to a " (:global -general-number) ". If "
           (:local phase) " is " (:tag compile) ", only constant conversions are permitted.")
    (define (object-to-general-number (o object) (phase phase)) general-number
      (const a primitive-object (object-to-primitive o hint-number phase))
      (case a
        (:select undefined (return nan64))
        (:select (union null (tag false)) (return +zero64))
        (:select (tag true) (return 1.0))
        (:narrow general-number (return a))
        (:narrow (union char16 string) (return (string-to-float64 (to-string a))))))
    
    
    (%text :comment (:global-call object-to-float32 o phase) " returns " (:local o) " converted to a " (:type float32) ". If "
           (:local phase) " is " (:tag compile) ", only constant conversions are permitted.")
    (define (object-to-float32 (o object) (phase phase)) float32
      (const a primitive-object (object-to-primitive o hint-number phase))
      (case a
        (:select undefined (return nan32))
        (:select (union null (tag false)) (return +zero32))
        (:select (tag true) (return (float32 1.0)))
        (:narrow general-number (return (to-float32 a)))
        (:narrow (union char16 string) (return (string-to-float32 (to-string a))))))
    
    
    (%text :comment (:global-call object-to-float64 o phase) " returns " (:local o) " converted to a " (:type float64) ". If "
           (:local phase) " is " (:tag compile) ", only constant conversions are permitted.")
    (define (object-to-float64 (o object) (phase phase)) float64
      (return (to-float64 (object-to-general-number o phase))))
    

    (%text :comment (:global-call object-to-extended-integer o phase) " returns " (:local o) " converted to an " (:type extended-integer) ". An error occurs if "
           (:local o) " has a fractional part or is a NaN. If " (:local o) " is a string, then it is converted exactly. If "
           (:local phase) " is " (:tag compile) ", only constant conversions are permitted.")
    (define (object-to-extended-integer (o object) (phase phase)) extended-integer
      (const a primitive-object (object-to-primitive o hint-number phase))
      (case a
        (:select (union null (tag false)) (return 0))
        (:select (tag true) (return 1))
        (:select (tag undefined nan32 nan64) (return nan))
        (:select (tag +infinity32 +infinity64) (return +infinity))
        (:select (tag -infinity32 -infinity64) (return -infinity))
        (:select (tag +zero32 +zero64 -zero32 -zero64) (return 0))
        (:narrow (union long u-long) (return (& value a)))
        (:narrow (union nonzero-finite-float32 nonzero-finite-float64)
          (const r rational (& value a))
          (rwhen (not-in r integer :narrow-false)
            (throw-error -range-error "the value " (:local a) " is not an integer"))
          (return r))
        (:narrow (union char16 string)
          (return (string-to-extended-integer (to-string a))))))
    

    (%text :comment (:global-call object-to-integer o phase) " returns " (:local o) " converted to an " (:type integer) ". An error occurs if "
           (:local o) " has a fractional part or is not finite. If " (:local o) " is a string, then it is converted exactly. If "
           (:local phase) " is " (:tag compile) ", only constant conversions are permitted.")
    (define (object-to-integer (o object) (phase phase)) integer
      (const i extended-integer (object-to-extended-integer o phase))
      (case i
        (:select (tag +infinity -infinity nan) (throw-error -range-error (:local i) " is not an integer"))
        (:narrow integer (return i))))
    

    (define (string-to-float32 (s string)) float32
      (/* "Apply the lexer grammar with the start symbol " (:grammar-symbol :string-numeric-literal nil "lexer-semantics.html") " to the string " (:local s) ".")
      (const q (union extended-rational (tag syntax-error))
        (lisp-call string-to-extended-rational (s)
                   (union extended-rational (tag syntax-error))
          "the result of lexing " (:operand 0) " using " (:grammar-symbol :string-numeric-literal nil "lexer-semantics.html") " as the start symbol"))
      (*/)
      (cond
       ((/*/ (in q (tag syntax-error) :narrow-false)
          "the grammar cannot interpret the entire string as an expansion of " (:grammar-symbol :string-numeric-literal nil "lexer-semantics.html"))
        (return nan32))
       (nil
        (// (:local q) ":" :nbsp (:type extended-rational) " " :assign-10 " the value of the action " (:action lex) " applied to the obtained expansion of the nonterminal "
            (:grammar-symbol :string-numeric-literal nil "lexer-semantics.html") ";")
        (return (extended-rational-to-float32 q)))))
    
    
    (define (string-to-float64 (s string)) float64
      (/* "Apply the lexer grammar with the start symbol " (:grammar-symbol :string-numeric-literal nil "lexer-semantics.html") " to the string " (:local s) ".")
      (const q (union extended-rational (tag syntax-error))
        (lisp-call string-to-extended-rational (s)
                   (union extended-rational (tag syntax-error))
          "the result of lexing " (:operand 0) " using " (:grammar-symbol :string-numeric-literal nil "lexer-semantics.html") " as the start symbol"))
      (*/)
      (cond
       ((/*/ (in q (tag syntax-error) :narrow-false)
          "the grammar cannot interpret the entire string as an expansion of " (:grammar-symbol :string-numeric-literal nil "lexer-semantics.html"))
        (return nan64))
       (nil
        (// (:local q) ":" :nbsp (:type extended-rational) " " :assign-10 " the value of the action " (:action lex) " applied to the obtained expansion of the nonterminal "
            (:grammar-symbol :string-numeric-literal nil "lexer-semantics.html") ";")
        (return (extended-rational-to-float64 q)))))
    
    
    (define (string-to-extended-integer (s string)) extended-integer
      (/* "Apply the lexer grammar with the start symbol " (:grammar-symbol :string-numeric-literal nil "lexer-semantics.html") " to the string " (:local s) ".")
      (const q (union extended-rational (tag syntax-error))
        (lisp-call string-to-extended-rational (s)
                   (union extended-rational (tag syntax-error))
          "the result of lexing " (:operand 0) " using " (:grammar-symbol :string-numeric-literal nil "lexer-semantics.html") " as the start symbol"))
      (*/)
      (cond
       ((/*/ (in q (tag syntax-error) :narrow-false)
          "the grammar cannot interpret the entire string as an expansion of " (:grammar-symbol :string-numeric-literal nil "lexer-semantics.html"))
        (throw-error -type-error "the string " (:local s) " does not contain a number"))
       (nil
        (// (:local q) ":" :nbsp (:type extended-rational) " " :assign-10 " the value of the action " (:action lex) " applied to the obtained expansion of the nonterminal "
            (:grammar-symbol :string-numeric-literal nil "lexer-semantics.html") ";")
        (case q
          (:select (tag +zero -zero) (return 0))
          (:narrow (tag +infinity -infinity nan) (return q))
          (:narrow rational
            (if (in q integer :narrow-true)
              (return q)
              (throw-error -range-error "the value should be an integer")))))))
    
    
    (%heading (3 :semantics) "Object to String Conversions")
    (%text :comment (:global-call object-to-string o phase) " returns " (:local o) " converted to a " (:global -string) ". If "
           (:local phase) " is " (:tag compile) ", only constant conversions are permitted.")
    (define (object-to-string (o object) (phase phase)) string
      (const a primitive-object (object-to-primitive o hint-string phase))
      (case a
        (:select undefined (return "undefined"))
        (:select null (return "null"))
        (:select (tag false) (return "false"))
        (:select (tag true) (return "true"))
        (:narrow general-number (return (general-number-to-string a)))
        (:narrow char16 (return (vector a)))
        (:narrow string (return a))))
    
    
    (define (to-string (o (union char16 string))) string
      (case o
        (:narrow char16 (return (vector o)))
        (:narrow string (return o))))
    
    
    (define (general-number-to-string (x general-number)) string
      (case x
        (:narrow (union long u-long) (return (integer-to-string (& value x))))
        (:narrow float32 (return (float32-to-string x)))
        (:narrow float64 (return (float64-to-string x)))))
    
    
    (%text :comment (:global-call integer-to-string i) " converts an integer " (:local i) " to a string of one or more decimal digits. If "
           (:local i) " is negative, the string is preceded by a minus sign.")
    (define (integer-to-string (i integer)) string
      (rwhen (< i 0)
        (return (cons #\- (integer-to-string (neg i)))))
      (const q integer (floor (rat/ i 10)))
      (const r integer (- i (* q 10)))
      (const c char16 (integer-to-char16 (+ r (char16-to-integer #\0))))
      (if (= q 0)
        (return (vector c))
        (return (append (integer-to-string q) (vector c)))))
    
    
    (%text :comment (:global-call integer-to-string-with-sign i) " is the same as " (:global-call integer-to-string i)
           " except that the resulting string always begins with a plus or minus sign.")
    (define (integer-to-string-with-sign (i integer)) string
      (if (>= i 0)
        (return (cons #\+ (integer-to-string i)))
        (return (cons #\- (integer-to-string (neg i))))))
    
    
    (define (exponential-notation-string (digits string) (e integer)) string
      (var mantissa string)
      (if (= (length digits) 1)
        (<- mantissa digits)
        (<- mantissa (append (vector (nth digits 0)) "." (subseq digits 1))))
      (return (append mantissa "e" (integer-to-string-with-sign e))))
    
    
    (%text :comment (:global-call float32-to-string x) " converts a " (:type float32) " " (:local x) " to a string using fixed-point notation if "
           "the absolute value of " (:local x) " is between " (:expr rational (expt 10 -6)) " inclusive and " (:expr rational (expt 10 21)) " exclusive, and "
           "exponential notation otherwise. The result has the fewest significant digits possible while still ensuring that converting the string back into a "
           (:type float32) " value would result in the same value " (:local x) " (except that " (:tag -zero32) " would become " (:tag +zero32) ").")
    (define (float32-to-string (x float32)) string
      (case x
        (:select (tag nan32) (return "NaN"))
        (:select (tag +zero32 -zero32) (return "0"))
        (:select (tag +infinity32) (return "Infinity"))
        (:select (tag -infinity32) (return "-Infinity"))
        (:narrow nonzero-finite-float32
          (const r rational (& value x))
          (cond
           ((< r 0 rational) (return (append "-" (float32-to-string (float32-negate x)))))
           (nil
            (/* (:def-const e integer) (:def-const k integer) (:def-const s integer)
                "Let " (:local e) ", " (:local k) ", and " (:local s) " be integers such that "
                (:expr boolean (>= k 1)) ", " (:expr boolean (cascade rational (expt 10 (- k 1)) <= s <= (expt 10 k))) ", "
                (:expr boolean (= (real-to-float32 (rat* s (expt 10 (- (+ e 1) k)))) x float32)) ", and " (:local k) " is as small as possible.")
            (multiple-value-bind ((digits string) (e integer)) decompose-positive-float32 (x))
            (const k integer (length digits))
            (*/)
            (note (:local k) " is the number of digits in the decimal representation of " (:local s) ", " (:local s)
                  " is not divisible by 10, and the least significant digit of " (:local s)
                  " is not necessarily uniquely determined by the above criteria.")
            (// (:def-const s integer) "When there are multiple possibilities for " (:local s) " according to the rules above, "
                "implementations are encouraged but not required to select the one according to the following rule: "
                "Select the value of " (:local s) " for which " (:expr rational (rat* s (expt 10 (- (+ e 1) k)))) " is closest in value to " (:local r)
                "; if there are two such possible values of " (:local s) ", choose the one that is even.")
            (// (:def-const s integer) (:local digits) ":" :nbsp (:type string) :nbsp :assign-10 :nbsp (:expr string (integer-to-string s)))
            (cond
             ((cascade integer (- k 1) <= e <= 20)
              (return (append digits (repeat char16 #\0 (- (+ e 1) k)))))
             ((cascade integer 0 <= e <= 20)
              (return (append (subseq digits 0 e) "." (subseq digits (+ e 1)))))
             ((cascade integer -6 <= e < 0)
              (return (append "0." (repeat char16 #\0 (neg (+ e 1))) digits)))
             (nil
              (return (exponential-notation-string digits e)))))))))
    ;(defprimitive float32-to-string (lambda (x) (float32-to-string x)))
    
    
    (%text :comment (:global-call float64-to-string x) " converts a " (:type float64) " " (:local x) " to a string using fixed-point notation if "
           "the absolute value of " (:local x) " is between " (:expr rational (expt 10 -6)) " inclusive and " (:expr rational (expt 10 21)) " exclusive, and "
           "exponential notation otherwise. The result has the fewest significant digits possible while still ensuring that converting the string back into a "
           (:type float64) " value would result in the same value " (:local x) " (except that " (:tag -zero64) " would become " (:tag +zero64) ").")
    (define (float64-to-string (x float64)) string
      (case x
        (:select (tag nan64) (return "NaN"))
        (:select (tag +zero64 -zero64) (return "0"))
        (:select (tag +infinity64) (return "Infinity"))
        (:select (tag -infinity64) (return "-Infinity"))
        (:narrow nonzero-finite-float64
          (const r rational (& value x))
          (cond
           ((< r 0 rational) (return (append "-" (float64-to-string (float64-negate x)))))
           (nil
            (/* (:def-const e integer) (:def-const k integer) (:def-const s integer)
                "Let " (:local e) ", " (:local k) ", and " (:local s) " be integers such that "
                (:expr boolean (>= k 1)) ", " (:expr boolean (cascade rational (expt 10 (- k 1)) <= s <= (expt 10 k))) ", "
                (:expr boolean (= (real-to-float64 (rat* s (expt 10 (- (+ e 1) k)))) x float64)) ", and " (:local k) " is as small as possible.")
            (multiple-value-bind ((digits string) (e integer)) decompose-positive-float64 (x))
            (const k integer (length digits))
            (*/)
            (note (:local k) " is the number of digits in the decimal representation of " (:local s) ", " (:local s)
                  " is not divisible by 10, and the least significant digit of " (:local s)
                  " is not necessarily uniquely determined by the above criteria.")
            (// (:def-const s integer) "When there are multiple possibilities for " (:local s) " according to the rules above, "
                "implementations are encouraged but not required to select the one according to the following rule: "
                "Select the value of " (:local s) " for which " (:expr rational (rat* s (expt 10 (- (+ e 1) k)))) " is closest in value to " (:local r)
                "; if there are two such possible values of " (:local s) ", choose the one that is even.")
            (// (:def-const s integer) (:local digits) ":" :nbsp (:type string) :nbsp :assign-10 :nbsp (:expr string (integer-to-string s)))
            (cond
             ((cascade integer (- k 1) <= e <= 20)
              (return (append digits (repeat char16 #\0 (- (+ e 1) k)))))
             ((cascade integer 0 <= e <= 20)
              (return (append (subseq digits 0 e) "." (subseq digits (+ e 1)))))
             ((cascade integer -6 <= e < 0)
              (return (append "0." (repeat char16 #\0 (neg (+ e 1))) digits)))
             (nil
              (return (exponential-notation-string digits e)))))))))
    ;(defprimitive float64-to-string (lambda (x) (float64-to-string x)))
    
    
    (%heading (3 :semantics) "Object to Qualified Name Conversion")
    (%text :comment (:global-call object-to-qualified-name o phase) " coerces an object " (:local o) " to a qualified name. If "
           (:local phase) " is " (:tag compile) ", only constant conversions are permitted.")
    (define (object-to-qualified-name (o object) (phase phase)) qualified-name
      (return (new qualified-name public (object-to-string o phase))))
    
    
    (%heading (3 :semantics) "Object to Class Conversion")
    (%text :comment (:global-call object-to-class o) " returns " (:local o) " converted to a non-" (:tag null) " " (:global -class) ".")
    (define (object-to-class (o object)) class
      (if (in o class :narrow-true)
        (return o)
        (throw-error -type-error)))
    
    
    (%heading (3 :semantics) "Object to Attribute Conversion")
    (%text :comment (:global-call object-to-attribute o) " returns " (:local o) " converted to an attribute.")
    (define (object-to-attribute (o object) (phase phase)) attribute
      (cond
       ((in o attribute :narrow-true) (return o))
       (nil
        (note "If " (:local o) " is not an attribute, try to call it with no arguments.")
        (const a object (call null o (vector-of object) phase))
        (if (in a attribute :narrow-true)
          (return a)
          (throw-error -type-error)))))
    
    
    (%heading (3 :semantics) "Implicit Coercions")
    (%text :comment (:global-call coerce o c) " attempts to implicitly coerce " (:local o) " to class " (:local c) ". If the coercion succeeds, "
           (:global coerce) " returns the coerced value. If not, " (:global coerce) " throws a " (:global -type-error) ".")
    (%text :comment "The coercion always succeeds and returns " (:local o) " unchanged if " (:local o) " is already a member of class " (:local c) ". The value returned from "
           (:global coerce) " always is a member of class " (:local c) ".")
    (define (coerce (o object) (c class)) object
      (const result object-opt ((& coerce c) o c))
      (if (not-in result (tag none) :narrow-true)
        (return result)
        (throw-error -type-error "coercion failed")))
    
    
    (%text :comment (:global-call coerce-or-null o c) " attempts to implicitly coerce " (:local o) " to class " (:local c) ". If the coercion succeeds, "
           (:global coerce-or-null) " returns the coerced value. If not, then " (:global coerce-or-null) " returns " (:tag null) " if "
           (:tag null) " is a member of type " (:local c) "; otherwise, " (:global coerce-or-null) " throws a " (:global -type-error) ".")
    (%text :comment "The coercion always succeeds and returns " (:local o) " unchanged if " (:local o) " is already a member of class " (:local c) ". The value returned from "
           (:global coerce-or-null) " always is a member of class " (:local c) ".")
    (define (coerce-or-null (o object) (c class)) object
      (const result object-opt ((& coerce c) o c))
      (cond
       ((not-in result (tag none) :narrow-true)
        (return result))
       ((= ((& coerce c) null c) null object-opt)
        (return null))
       (nil (throw-error -type-error "coercion failed"))))
    
    
    (%text :comment (:global-call coerce-non-null o c) " attempts to implicitly coerce " (:local o) " to class " (:local c)
           ". If the coercion succeeds and the result is not " (:tag null) ", then "
           (:global coerce-non-null) " returns the coerced value. If not, " (:global coerce-non-null) " throws a " (:global -type-error) ".")
    (define (coerce-non-null (o object) (c class)) object
      (const result object-opt ((& coerce c) o c))
      (if (not-in result (tag none null) :narrow-true)
        (return result)
        (throw-error -type-error "coercion failed")))
    
    
    (%text :comment (:global-call ordinary-coerce o c) " is the implementation of coercion for a native class unless specified otherwise in the class" :apostrophe
           "s definition. Host classes may define a different procedure to perform this coercion.")
    (define (ordinary-coerce (o object) (c class)) object-opt
      (if (or (in o (tag null)) (is o c))
        (return o)
        (return none)))
    
    
    (%heading (3 :semantics) "Attributes")
    (%text :comment (:global-call combine-attributes a b) " returns the attribute that results from concatenating the attributes "
           (:local a) " and " (:local b) ".")
    (define (combine-attributes (a attribute-opt-not-false) (b attribute)) attribute
      (cond
       ((in b false-type :narrow-false) (return false))
       ((in a (tag none true) :narrow-false) (return b))
       ((in b true-type :narrow-false) (return a))
       ((in a namespace :narrow-both)
        (cond
         ((= a b attribute) (return a))
         ((in b namespace :narrow-both)
          (return (new compound-attribute (list-set a b) false false false none none false false)))
         (nil
          (return (set-field b namespaces (set+ (& namespaces b) (list-set a)))))))
       ((in b namespace :narrow-both)
        (return (set-field a namespaces (set+ (& namespaces a) (list-set b)))))
       (nil
        (note "At this point both " (:local a) " and " (:local b) " are compound attributes.")
        (if (or (and (not-in (& category a) (tag none)) (not-in (& category b) (tag none)) (/= (& category a) (& category b) property-category))
                (and (not-in (& override-mod a) (tag none)) (not-in (& override-mod b) (tag none)) (/= (& override-mod a) (& override-mod b) override-modifier)))
          (throw-error -attribute-error "attributes " (:local a) " and " (:local b) " have conflicting contents")
          (return (new compound-attribute
                       (set+ (& namespaces a) (& namespaces b))
                       (or (& explicit a) (& explicit b))
                       (or (& enumerable a) (& enumerable b))
                       (or (& dynamic a) (& dynamic b))
                       (if (not-in (& category a) (tag none)) (& category a) (& category b))
                       (if (not-in (& override-mod a) (tag none)) (& override-mod a) (& override-mod b))
                       (or (& prototype a) (& prototype b))
                       (or (& unused a) (& unused b))))))))
    
    
    (%text :comment (:global-call to-compound-attribute a) " returns " (:local a) " converted to a " (:type compound-attribute)
           " even if it was a simple namespace, " (:tag true) ", or " (:tag none) ".")
    (define (to-compound-attribute (a attribute-opt-not-false)) compound-attribute
      (case a
        (:select (tag none true) (return (new compound-attribute (list-set-of namespace) false false false none none false false)))
        (:narrow namespace (return (new compound-attribute (list-set a) false false false none none false false)))
        (:narrow compound-attribute (return a))))
    
    
    (%heading (2 :semantics) "Access Utilities")
    (%text :comment (:global-call accesses-overlap accesses1 accesses2) " returns " (:tag true) " if the two " (:type access-set) "s have a nonempty intersection.")
    (define (accesses-overlap (accesses1 access-set) (accesses2 access-set)) boolean
      (return (or (= accesses1 accesses2 access-set)
                  (in accesses1 (tag read-write))
                  (in accesses2 (tag read-write)))))
    
    
    (define (archetype (o object)) object-opt
      (case o
        (:select (union undefined null) (return none))
        (:select boolean (return (&opt prototype -boolean)))
        (:select long (return (&opt prototype \#long)))
        (:select u-long (return (&opt prototype ulong)))
        (:select float32 (return (&opt prototype float)))
        (:select float64 (return (&opt prototype -number)))
        (:select char16 (return (&opt prototype char)))
        (:select string (return (&opt prototype -string)))
        (:select namespace (return (&opt prototype -namespace)))
        (:select compound-attribute (return (&opt prototype -attribute)))
        (:select method-closure (return (&opt prototype -function)))
        (:select class (return (&opt prototype -class)))
        (:narrow (union simple-instance reg-exp date package) (return (&opt archetype o)))))
    
    
    (%text :comment (:global-call archetypes o) " returns the set of " (:local o) :apostrophe "s archetypes, not including " (:local o) " itself.")
    (define (archetypes (o object)) (list-set object)
      (const a object-opt (archetype o))
      (rwhen (in a (tag none) :narrow-false)
        (return (list-set-of object)))
      (return (set+ (list-set a) (archetypes a))))
    
    
    (%text :comment (:local o) " is an object that is known to have slot " (:local id) ". " (:global-call find-slot o id) " returns that slot.")
    (define (find-slot (o object) (id instance-variable)) slot
      (assert (in o (union simple-instance method-closure) :narrow-true)
        (:local o) " must be a " (:type simple-instance) " or a " (:type method-closure) " in order to have slots.")
      (const matching-slots (list-set slot)
        (map (& slots o) s s (= (& id s) id instance-variable)))
      (return (unique-elt-of matching-slots)))
    
    
    (%text :comment (:global-call setup-variable v) " runs " (:action setup) " and initialises the type of the variable " (:local v)
           ", making sure that " (:action setup) " is done at most once and does not reenter itself.")
    (define (setup-variable (v variable)) void
      (const setup (union (-> () class-opt) (tag none busy)) (& setup v))
      (case setup
        (:narrow (-> () class-opt)
          (&= setup v busy)
          (var type class-opt (setup))
          (when (in type (tag none))
            (<- type -object))
          (quiet-assert (not-in type (tag none) :narrow-true))
          (&const= type v type)
          (&= setup v none))
        (:select (tag none))
        (:select (tag busy)
          (throw-error -constant-error "a constant" :apostrophe "s type or initialiser cannot depend on the value of that constant"))))
    
    
    (%text :comment (:def-const v variable) (:global-call write-variable v new-value clear-initializer) " writes the value " (:local new-value) " into the mutable or immutable variable "
           (:local v) ". " (:local new-value) " is coerced to " (:local v) :apostrophe "s type. If the " (:local clear-initializer) " flag is set, then the caller "
           " has just evaluated " (:local v) :apostrophe "s initialiser and is supplying its result in " (:local new-value) ". In this case " (:global write-variable)
           " atomically clears " (:expr (union initializer (tag none busy)) (& initializer v)) " while writing "
           (:expr variable-value (& value v)) ". In all other cases the presence of an initialiser or an existing value will prevent an immutable variable" :apostrophe
           "s value from being written.")
    (define (write-variable (v variable) (new-value object) (clear-initializer boolean)) object
      (const coerced-value object (coerce new-value (&opt type v)))
      (when clear-initializer
        (&= initializer v none))
      (rwhen (and (& immutable v) (or (not-in (& value v) (tag none)) (not-in (& initializer v) (tag none))))
        (throw-error -reference-error "cannot initialise a " (:character-literal "const") " variable twice"))
      (&= value v coerced-value)
      (return coerced-value))
    
    
    (%heading (2 :semantics) "Environmental Utilities")
    
    (%text :comment "If " (:local env) " is from within a class" :apostrophe "s body, "
           (:global-call get-enclosing-class env) " returns the innermost such class; otherwise, it returns " (:tag none) ".")
    (define (get-enclosing-class (env environment)) class-opt
      (reserve c)
      (rwhen (some env c (in c class :narrow-true) :define-true)
        (// "Let " (:local c) " be the first element of " (:local env) " that is a " (:type class) ".")
        (return c))
      (return none))
    
    
    (%text :comment "If " (:local env) " is from within a function" :apostrophe "s body, "
           (:global-call get-enclosing-parameter-frame env) " returns the " (:type parameter-frame) " for the innermost such function; otherwise, it returns " (:tag none) ".")
    (define (get-enclosing-parameter-frame (env environment)) parameter-frame-opt
      (for-each env frame
        (case frame
          (:select (union local-frame with-frame))
          (:narrow parameter-frame (return frame))
          (:select (union package class) (return none))))
      (return none))
    
    
    (%text :comment (:global-call get-regional-environment env) " returns all frames in " (:local env) " up to and including the first regional frame. "
           "A regional frame is either any frame other than a with frame or local block frame, a local block frame directly enclosed in a class, or "
           "a local block frame directly enclosed in a with frame directly enclosed in a class.")
    (define (get-regional-environment (env environment)) (vector frame)
      (var i integer 0)
      (while (in (nth env i) (union local-frame with-frame))
        (<- i (+ i 1)))
      (when (in (nth env i) class)
        (while (and (/= i 0) (not-in (nth env i) local-frame))
          (<- i (- i 1))))
      (return (subseq env 0 i)))
    
    
    (%text :comment (:global-call get-regional-frame env) " returns the most specific regional frame in " (:local env) ".")
    (define (get-regional-frame (env environment)) frame
      (const regional-env (vector frame) (get-regional-environment env))
      (return (nth regional-env (- (length regional-env) 1))))
    
    
    (%text :comment (:global-call get-package-frame env) " returns the innermost package frame in " (:local env) ".")
    (define (get-package-frame (env environment)) package
      (var i integer 0)
      (while (not-in (nth env i) package)
        (<- i (+ i 1)))
      (note "Every environment ends with a " (:type package) " frame, so one will always be found.")
      (return (assert-in (nth env i) package)))
    
    
    
    (%heading (2 :semantics) "Property Lookup")
    
    (%text :comment (:global-call find-local-singleton-property o multiname access) " looks in " (:local o) " for a local singleton property with one of the names in "
           (:local multiname) " and access that includes " (:local access) ". If there is no such property, " (:global find-local-singleton-property)
           " returns " (:tag none) ". If there is exactly one such property, " (:global find-local-singleton-property)
           " returns it. If there is more than one such property, " (:global find-local-singleton-property) " throws an error.")
    (define (find-local-singleton-property (o (union non-with-frame simple-instance reg-exp date)) (multiname multiname) (access access))
            singleton-property-opt
      (const matching-local-bindings (list-set local-binding)
        (map (& local-bindings o) b b (and (set-in (& qname b) multiname) (accesses-overlap (& accesses b) access))))
      (note "If the same property was found via several different bindings " (:local b)
            ", then it will appear only once in the set " (:local matching-properties) ".")
      (const matching-properties (list-set singleton-property) (map matching-local-bindings b (& content b)))
      (cond
       ((empty matching-properties)
        (return none))
       ((= (length matching-properties) 1)
        (return (unique-elt-of matching-properties)))
       (nil
        (throw-error -reference-error "this access is ambiguous because the bindings it found belong to several different local properties"))))
    
    
    (%text :comment (:global-call instance-property-accesses m) " returns instance property" :apostrophe "s " (:type access-set) ".")
    (define (instance-property-accesses (m instance-property)) access-set
      (case m
        (:select (union instance-variable instance-method) (return read-write))
        (:select instance-getter (return read))
        (:select instance-setter (return write))))
    
    
    (%text :comment (:global-call find-local-instance-property c multiname accesses) " looks in class " (:local c) " for a local instance property with one of the names in "
           (:local multiname) " and accesses that have a nonempty intersection with " (:local accesses) ". If there is no such property, " (:global find-local-instance-property)
           " returns " (:tag none) ". If there is exactly one such property, " (:global find-local-instance-property)
           " returns it. If there is more than one such property, " (:global find-local-instance-property) " throws an error.")
    (define (find-local-instance-property (c class) (multiname multiname) (accesses access-set))
            instance-property-opt
      (const matches (list-set instance-property)
        (map (& instance-properties c) m m (and (nonempty (set* (&opt multiname m) multiname)) (accesses-overlap (instance-property-accesses m) accesses))))
      (cond
       ((empty matches)
        (return none))
       ((= (length matches) 1)
        (return (unique-elt-of matches)))
       (nil
        (throw-error -reference-error "this access is ambiguous because it found several different instance properties in the same class"))))
    
    
    (%text :comment (:global-call find-archetype-property o multiname access flat) " looks in object " (:local o)
           " for any local or inherited property with one of the names in "
           (:local multiname) " and access that includes " (:local access) ". If " (:local flat) " is " (:tag true)
           ", then properties inherited from the archetype are not considered in the search. If it finds no property, " (:global find-archetype-property)
           " returns " (:tag none) ". If it finds one property, " (:global find-archetype-property)
           " returns it. If it finds more than one property, " (:global find-archetype-property) " prefers the more local one in the list of " (:local o) :apostrophe
           "s superclasses or archetypes; if two or more properties remain, the singleton one is preferred; if two or more properties still remain, "
           (:global find-archetype-property) " throws an error.")
    (%text :comment "Note that " (:global-call find-archetype-property o multiname access flat) " searches " (:local o) " itself rather than " (:local o) :apostrophe
           "s class for properties. " (:global find-archetype-property) " will not find instance properties unless " (:local o) " is a class.")
    (define (find-archetype-property (o object) (multiname multiname) (access access) (flat boolean))
            property-opt
      (var m property-opt)
      (case o
        (:select (union undefined null boolean long u-long float32 float64 char16 string namespace compound-attribute method-closure)
          (<- m none))
        (:narrow (union simple-instance reg-exp date package)
          (<- m (find-local-singleton-property o multiname access)))
        (:narrow class
          (<- m (find-class-property o multiname access))))
      (rwhen (not-in m (tag none))
        (return m))
      (rwhen flat
        (return none))
      (const a object-opt (archetype o))
      (rwhen (in a (tag none) :narrow-false)
        (return none))
      (return (find-archetype-property a multiname access flat)))
    
    
    (define (find-class-property (c class) (multiname multiname) (access access))
            property-opt
      (var m property-opt (find-local-singleton-property c multiname access))
      (when (in m (tag none))
        (<- m (find-local-instance-property c multiname access))
        (when (in m (tag none))
          (const super class-opt (& super c))
          (when (not-in super (tag none) :narrow-true)
            (<- m (find-class-property super multiname access)))))
      (return m))
    
    
    (%text :comment (:global-call find-base-instance-property c multiname accesses) " looks in class " (:local c)
           " and its ancestors for an instance property with one of the names in "
           (:local multiname) " and accesses that have a nonempty intersection with " (:local accesses) ". If there is no such property, " (:global find-base-instance-property)
           " returns " (:tag none) ". If there is exactly one such property, " (:global find-base-instance-property)
           " returns it. If there is more than one such property, " (:global find-base-instance-property)
           " prefers the one defined in the least specific class; if two or more properties still remain, "
           (:global find-base-instance-property) " throws an error.")
    (define (find-base-instance-property (c class) (multiname multiname) (accesses access-set))
            instance-property-opt
      (note "Start from the root class (" (:character-literal "Object") ") and proceed through more specific classes that are ancestors of " (:local c) ".")
      (for-each (ancestors c) s
        (const m instance-property-opt (find-local-instance-property s multiname accesses))
        (rwhen (not-in m (tag none))
          (return m)))
      (return none))
    
    
    (%text :comment (:global-call get-derived-instance-property c m-base accesses) " returns the most derived instance property whose name includes that of " (:local m-base)
           " and whose accesses that have a nonempty intersection with " (:local accesses) ". The caller of " (:global get-derived-instance-property)
           " ensures that such an instance property always exists. "
           "If " (:local accesses) " is " (:tag read-write) " then it is possible that this search could find both a getter and a setter defined in the same class; "
           "in this case either the getter or the setter is returned at the implementation" :apostrophe "s discretion.")
    (define (get-derived-instance-property (c class) (m-base instance-property) (accesses access-set)) instance-property
      (reserve m)
      (if (some (& instance-properties c) m (and (set<= (&opt multiname m-base) (&opt multiname m) multiname)
                                                 (accesses-overlap (instance-property-accesses m) accesses)) :define-true)
        (return m)
        (return (get-derived-instance-property (assert-not-in (& super c) (tag none)) m-base accesses))))
    
     
    (%text :comment (:global-call read-implicit-this env) " returns the value of implicit " (:character-literal "this")
           " to be used to access instance properties within a class" :apostrophe "s scope without using the " (:character-literal ".") " operator. An implicit "
           (:character-literal "this") " is well-defined only inside instance methods and constructors; " (:global read-implicit-this)
           " throws an error if there is no well-defined implicit " (:character-literal "this") " value or if an attempt is made to read it before it has been initialised.")
    (define (read-implicit-this (env environment)) object
      (const frame parameter-frame-opt (get-enclosing-parameter-frame env))
      (rwhen (in frame (tag none) :narrow-false)
        (throw-error -reference-error "can" :apostrophe "t access instance properties outside an instance method without supplying an instance object"))
      (const this object-opt (& this frame))
      (rwhen (in this (tag none) :narrow-false)
        (throw-error -reference-error "can" :apostrophe "t access instance properties inside a non-instance method without supplying an instance object"))
      (rwhen (not-in (& kind frame) (tag instance-function constructor-function))
        (throw-error -reference-error "can" :apostrophe "t access instance properties inside a non-instance method without supplying an instance object"))
      (rwhen (not (& superconstructor-called frame))
        (throw-error -uninitialized-error "can" :apostrophe "t access instance properties from within a constructor before the superconstructor has been called"))
      (return this))
    
    
    (%text :comment (:global-call has-property o property flat phase) " returns " (:tag true) " if " (:local o) " has a readable or writable property named "
           (:local property) ". If " (:local flat) " is " (:tag true) ", then properties inherited from the archetype are not considered.")
    (define (has-property (o object) (property object) (flat boolean) (phase phase)) boolean
      (const c class (object-type o))
      (return ((& has-property c) o c property flat phase)))
    
    
    (%text :comment (:global-call has-property o c property flat phase) " is the implementation of " (:global has-property)
           " for a native class unless specified otherwise in the class" :apostrophe
           "s definition. Host classes may either also use " (:global ordinary-has-property) " or define a different procedure to perform this test. "
           (:local c) " is " (:local o) :apostrophe "s type.")
    (define (ordinary-has-property (o object) (c class) (property object) (flat boolean) (phase phase)) boolean
      (const qname qualified-name (object-to-qualified-name property phase))
      (return (or (not-in (find-base-instance-property c (list-set qname) read) (tag none))
                  (not-in (find-base-instance-property c (list-set qname) write) (tag none))
                  (not-in (find-archetype-property o (list-set qname) read flat) (tag none))
                  (not-in (find-archetype-property o (list-set qname) write flat) (tag none)))))
    
    
    (%heading (2 :semantics) "Reading")
    (%text :comment "If " (:local r) " is an " (:type object) ", " (:global-call read-reference r phase) " returns it unchanged.  If "
           (:local r) " is a " (:type reference) ", " (:global read-reference) " reads " (:local r) " and returns the result. If "
           (:local phase) " is " (:tag compile) ", only constant expressions can be evaluated in the process of reading " (:local r) ".")
    (define (read-reference (r obj-or-ref) (phase phase)) object
      (var result object-opt)
      (case r
        (:narrow object (<- result r))
        (:narrow lexical-reference (<- result (lexical-read (& env r) (& variable-multiname r) phase)))
        (:narrow dot-reference
          (<- result ((& read (& limit r)) (& base r) (& limit r) (& multiname r) none true phase)))
        (:narrow bracket-reference
          (<- result ((& bracket-read (& limit r)) (& base r) (& limit r) (& args r) true phase))))
      (if (not-in result (tag none) :narrow-true)
        (return result)
        (throw-error -reference-error "property not found, and no default value is available")))
    
    
    (%text :comment (:global-call dot-read o multiname phase) " reads and returns the value of the " (:local multiname) " property of " (:local o) ". "
           (:global dot-read) " throws an error if the property does not exist and no default value was available for it.")
    (define (dot-read (o object) (multiname multiname) (phase phase))
            object
      (const limit class (object-type o))
      (const result object-opt ((& read limit) o limit multiname none true phase))
      (rwhen (in result (tag none) :narrow-false)
        (throw-error -reference-error "property not found, and no default value is available"))
      (return result))
    
    
    (%text :comment (:global-call read-length o phase) " reads and returns the value of the " (:character-literal "length") " property of " (:local o)
           ", ensuring that it is an integer between 0 and " (:global array-limit) " inclusive.")
    (define (read-length (o object) (phase phase)) integer
      (var value object (dot-read o (list-set (new qualified-name public "length")) phase))
      (rwhen (not-in value general-number :narrow-false)
        (throw-error -type-error "length not an integer"))
      (const length integer-opt (check-integer value))
      (cond
       ((in length (tag none) :narrow-false) (throw-error -range-error "length not an integer"))
       ((cascade integer 0 <= length <= array-limit) (return length))
       (nil (throw-error -range-error "length out of range"))))
    
    
    (%text :comment (:global-call index-read o i phase) " returns the value of " (:local o) (:character-literal "[") (:local i) (:character-literal "]")
           " or " (:tag none) " if no such property was found; unlike " (:global dot-read) ", " (:global index-read)
           " does not return a default value for missing properties. " (:local i) " should always be a valid array index.")
    (define (index-read (o object) (i integer) (phase phase))
            object-opt
      (assert (cascade integer 0 <= i < array-limit))
      (const limit class (object-type o))
      (const x float64 (real-to-float64 i))
      (const result object-opt ((& bracket-read limit) o limit (vector x) false phase))
      (when (and (not-in result (tag none)) (not (has-property o x true phase)))
        (// "At the implementation" :apostrophe "s discretion either do nothing, set " (:local result) " to " (:tag none) ", or "
            (:keyword throw) " a " (:global -reference-error) "."))
      (return result))
    
    
    (%text :comment (:def-const o object) (:global-call ordinary-bracket-read o limit args undefined-if-missing phase) " evaluates the expression "
           (:local o) (:character-literal "[") (:local args) (:character-literal "]") " when " (:local o) " is a native object. Host objects may either also use "
           (:global ordinary-bracket-read) " or choose a different procedure " (:local -p) " to evaluate " (:local o) (:character-literal "[") (:local args) (:character-literal "]")
           " by writing " (:local -p) " into " (:expr (-> (object class (vector object) boolean phase) object-opt) (& bracket-read (object-type o))) ".")
    (%text :comment (:def-const o object) (:local limit) " is used to handle the expression "
           (:character-literal "super(") (:local o) (:character-literal ")[") (:local args) (:character-literal "]")
           ", in which case " (:local limit) " is the superclass of the class inside which the " (:character-literal "super") " expression appears. "
           "Otherwise, " (:local limit) " is set to " (:expr class (object-type o)) ".")
    (define (ordinary-bracket-read (o object) (limit class) (args (vector object)) (undefined-if-missing boolean) (phase phase)) object-opt
      (rwhen (/= (length args) 1)
        (throw-error -argument-error "exactly one argument must be supplied"))
      (const qname qualified-name (object-to-qualified-name (nth args 0) phase))
      (return ((& read limit) o limit (list-set qname) none undefined-if-missing phase)))
    
    
    (define (lexical-read (env environment) (multiname multiname) (phase phase)) object
      (var i integer 0)
      (while (< i (length env))
        (const frame frame (nth env i))
        (var result object-opt none)
        (case frame
          (:narrow (union package class)
            (const limit class (object-type frame))
            (<- result ((& read limit) frame limit multiname env false phase)))
          (:narrow (union parameter-frame local-frame)
            (const m singleton-property-opt (find-local-singleton-property frame multiname read))
            (when (not-in m (tag none) :narrow-true)
              (<- result (read-singleton-property m phase))))
          (:narrow with-frame
            (const value object-opt (& value frame))
            (rwhen (in value (tag none) :narrow-false)
              (case phase
                (:select (tag compile)
                  (throw-error -constant-error "cannot read a " (:character-literal "with") " statement" :apostrophe "s frame from a constant expression"))
                (:select (tag run)
                  (throw-error -uninitialized-error
                    "cannot read a " (:character-literal "with") " statement" :apostrophe "s frame before that statement" :apostrophe
                    "s expression has been evaluated"))))
            (const limit class (object-type value))
            (<- result ((& read limit) value limit multiname env false phase))))
        (rwhen (not-in result (tag none) :narrow-true)
          (return result))
        (<- i (+ i 1)))
      (throw-error -reference-error "no property found with the name " (:local multiname)))
    
    
    (define (ordinary-read (o object) (limit class) (multiname multiname) (env environment-opt) (undefined-if-missing boolean) (phase phase))
            object-opt
      (const m-base instance-property-opt (find-base-instance-property limit multiname read))
      (rwhen (not-in m-base (tag none) :narrow-true)
        (return (read-instance-property o limit m-base phase)))
      (rwhen (/= limit (object-type o) class)
        (return none))
      (const flat boolean (and (not-in env (tag none)) (in o class)))
      (const m property-opt (find-archetype-property o multiname read flat))
      (case m
        (:select (tag none)
          (if (and undefined-if-missing
                   (in o (union simple-instance date reg-exp package) :narrow-true)
                   (not (& sealed o)))
            (case phase
              (:select (tag compile) (throw-error -constant-error "a constant expression cannot read dynamic properties"))
              (:select (tag run) (return undefined)))
            (return none)))
        (:narrow singleton-property (return (read-singleton-property m phase)))
        (:narrow instance-property
          (rwhen (or (not-in o class :narrow-false) (in env (tag none) :narrow-false))
            (throw-error -reference-error "cannot read an instance property without supplying an instance"))
          (const this object (read-implicit-this env))
          (return (read-instance-property this (object-type this) m phase)))))
    
    
    (%text :comment (:global-call read-instance-property o qname phase) " is a simplified interface to "
           (:global ordinary-read) " used to read instance slots that are known to exist.")
    (define (read-instance-slot (o object) (qname qualified-name) (phase phase))
            object
      (const c class (object-type o))
      (const m-base instance-property-opt (find-base-instance-property c (list-set qname) read))
      (assert (not-in m-base (tag none) :narrow-true)
        (:global read-instance-property) " is only called in cases where the instance property is known to exist, so " (:local m-base) " cannot be " (:tag none) " here.")
      (return (read-instance-property o c m-base phase)))
    
    
    (define (read-instance-property (this object) (c class) (m-base instance-property) (phase phase))
            object
      (const m instance-property (get-derived-instance-property c m-base read))
      (case m
        (:narrow instance-variable
          (rwhen (and (in phase (tag compile)) (not (& immutable m)))
            (throw-error -constant-error "a constant expression cannot read mutable variables"))
          (const v object-opt (& value (find-slot this m)))
          (rwhen (in v (tag none) :narrow-false)
            (case phase
              (:select (tag compile) (throw-error -constant-error "cannot read uninitalised " (:character-literal "const") " variables from a constant expression"))
              (:select (tag run) (throw-error -uninitialized-error "cannot read a " (:character-literal "const") " instance variable before it is initialised"))))
          (return v))
        (:narrow instance-method
          (const slots (list-set slot) (list-set (new slot ivar-function-length (real-to-float64 (& length m)))))
          (return (new method-closure this m slots)))
        (:narrow instance-getter
          (return ((& call m) this phase)))
        (:narrow instance-setter
          (bottom (:local m) " cannot be an " (:type instance-setter) " because these are only represented as write-only properties."))))
    
    
    (define (read-singleton-property (m singleton-property) (phase phase)) object
      (case m
        (:select (tag forbidden)
          (throw-error -reference-error "cannot access a property defined in a scope outside the current region if any block inside the current region shadows it"))
        (:narrow dynamic-var
          (rwhen (in phase (tag compile))
            (throw-error -constant-error "a constant expression cannot read mutable variables"))
          (var value (union object uninstantiated-function) (& value m))
          (assert (not-in value uninstantiated-function :narrow-true)
            (:local value) " can be an " (:type uninstantiated-function) " only during the " (:tag compile) " phase, which was ruled out above.")
          (return value))
        (:narrow variable
          (rwhen (and (in phase (tag compile)) (not (& immutable m)))
            (throw-error -constant-error "a constant expression cannot read mutable variables"))
          (const value variable-value (& value m))
          (case value
            (:narrow object (return value))
            (:select (tag none)
              (rwhen (not (& immutable m))
                (throw-error -uninitialized-error))
              (note "Try to run a " (:character-literal "const") " variable" :apostrophe "s initialiser if there is one.")
              (setup-variable m)
              (const initializer (union initializer (tag none busy)) (& initializer m))
              (rwhen (in initializer (tag none busy) :narrow-false)
                (case phase
                  (:select (tag compile) (throw-error -constant-error "a constant expression cannot access a constant with a missing or recursive initialiser"))
                  (:select (tag run) (throw-error -uninitialized-error))))
              (&= initializer m busy)
              (var coerced-value object)
              (catch ((const new-value object (initializer (&opt initializer-env m) compile))
                      (<- coerced-value (write-variable m new-value true)))
                (x)
                (note "If initialisation failed, restore " (:expr (union initializer (tag none busy)) (& initializer m)) " to its original value so it can be tried later.")
                (&= initializer m initializer)
                (throw x))
              (return coerced-value))
            (:select uninstantiated-function
              (assert (in phase (tag compile)) "An uninstantiated function can only be found when " (:assertion) ".")
              (throw-error -constant-error "an uninstantiated function is not a constant expression"))))
        (:narrow getter
          (const env environment-opt (& env m))
          (rwhen (in env (tag none) :narrow-false)
            (assert (in phase (tag compile)) "An uninstantiated getter can only be found when " (:assertion) ".")
            (throw-error -constant-error "an uninstantiated getter is not a constant expression"))
          (return ((& call m) env phase)))
        (:narrow setter
          (bottom (:local m) " cannot be a " (:type setter) " because these are only represented as write-only properties."))))
    
    
    (%heading (2 :semantics) "Writing")
    (%text :comment "If " (:local r) " is a reference, " (:global-call write-reference r new-value) " writes " (:local new-value) 
           " into " (:local r) ". An error occurs if " (:local r) " is not a reference. "
           (:global write-reference) " is never called from a constant expression.")
    (define (write-reference (r obj-or-ref) (new-value object) (phase (tag run))) void
      (var result (tag none ok))
      (case r
        (:select object (throw-error -reference-error "a non-reference is not a valid target of an assignment"))
        (:narrow lexical-reference
          (lexical-write (& env r) (& variable-multiname r) new-value (not (& strict r)) phase)
          (<- result ok))
        (:narrow dot-reference
          (<- result ((& write (& limit r)) (& base r) (& limit r) (& multiname r) none new-value true phase)))
        (:narrow bracket-reference
          (<- result ((& bracket-write (& limit r)) (& base r) (& limit r) (& args r) new-value true phase))))
      (rwhen (in result (tag none))
        (throw-error -reference-error "property not found and could not be created")))
    
    
    (%text :comment (:global-call dot-write o multiname new-value phase) " is a simplified interface to write " (:local new-value)
           " into the " (:local multiname) " property of " (:local o) ".")
    (define (dot-write (o object) (multiname multiname) (new-value object) (phase (tag run)))
            void
      (const limit class (object-type o))
      (const result (tag none ok) ((& write limit) o limit multiname none new-value true phase))
      (rwhen (in result (tag none))
        (throw-error -reference-error "property not found and could not be created")))
    
    
    (%text :comment (:global-call write-length o length phase) " ensures that " (:local length) " is between 0 and " (:global array-limit)
           " inclusive and then writes it into the " (:character-literal "length") " property of " (:local o) ". Note that if " (:local o)
           " is an " (:character-literal "Array") ", the act of writing its " (:character-literal "length") " property will invoke the "
           (:global -array_set-length) " setter.")
    (define (write-length (o object) (length integer) (phase (tag run))) void
      (rwhen (or (< length 0) (> length array-limit))
        (throw-error -range-error "length out of range"))
      (dot-write o (list-set (new qualified-name public "length")) (real-to-float64 length) phase))
    
    
    (define (index-write (o object) (i integer) (new-value object-opt) (phase (tag run)))
            void
      (rwhen (or (< i 0) (>= i array-limit))
        (throw-error -range-error "index out of range"))
      (const limit class (object-type o))
      (cond
       ((in new-value (tag none) :narrow-false)
        (const delete-result boolean-opt ((& bracket-delete limit) o limit (vector (real-to-float64 i)) phase))
        (rwhen (in delete-result (tag false))
          (throw-error -reference-error "cannot delete element")))
       (nil
        (const write-result (tag none ok) ((& bracket-write limit) o limit (vector (real-to-float64 i)) new-value true phase))
        (rwhen (in write-result (tag none))
          (throw-error -reference-error "element not found and could not be created")))))
    
    
    (define (ordinary-bracket-write (o object) (limit class) (args (vector object)) (new-value object) (create-if-missing boolean) (phase (tag run)))
            (tag none ok)
      (rwhen (/= (length args) 1)
        (throw-error -argument-error "exactly one argument must be supplied"))
      (const qname qualified-name (object-to-qualified-name (nth args 0) phase))
      (return ((& write limit) o limit (list-set qname) none new-value create-if-missing phase)))
    
    
    (define (lexical-write (env environment) (multiname multiname) (new-value object) (create-if-missing boolean) (phase (tag run))) void
      (var i integer 0)
      (while (< i (length env))
        (const frame frame (nth env i))
        (var result (tag none ok) none)
        (case frame
          (:narrow (union package class)
            (const limit class (object-type frame))
            (<- result ((& write limit) frame limit multiname env new-value false phase)))
          (:narrow (union parameter-frame local-frame)
            (const m singleton-property-opt (find-local-singleton-property frame multiname write))
            (when (not-in m (tag none) :narrow-true)
              (write-singleton-property m new-value phase)
              (<- result ok)))
          (:narrow with-frame
            (const value object-opt (& value frame))
            (rwhen (in value (tag none) :narrow-false)
              (throw-error -uninitialized-error
                "cannot read a " (:character-literal "with") " statement" :apostrophe "s frame before that statement" :apostrophe
                "s expression has been evaluated"))
            (const limit class (object-type value))
            (<- result ((& write limit) value limit multiname env new-value false phase))))
        (rwhen (in result (tag ok))
          (return))
        (<- i (+ i 1)))
      (when create-if-missing
        (const pkg package (get-package-frame env))
        (note "Try to write the variable into " (:local pkg) " again, this time allowing new dynamic bindings to be created dynamically.")
        (const limit class (object-type pkg))
        (const result (tag none ok) ((& write limit) pkg limit multiname env new-value true phase))
        (rwhen (in result (tag ok))
          (return)))
      (throw-error -reference-error "no existing property found with the name " (:local multiname) " and one could not be created"))
    
    
    (define (ordinary-write (o object) (limit class) (multiname multiname) (env environment-opt) (new-value object) (create-if-missing boolean) (phase (tag run)))
            (tag none ok)
      (const m-base instance-property-opt (find-base-instance-property limit multiname write))
      (rwhen (not-in m-base (tag none) :narrow-true)
        (write-instance-property o limit m-base new-value phase)
        (return ok))
      (rwhen (/= limit (object-type o) class)
        (return none))
      (const m property-opt (find-archetype-property o multiname write true))
      (case m
        (:select (tag none)
          (reserve qname)
          (when (and create-if-missing
                     (in o (union simple-instance date reg-exp package) :narrow-true)
                     (not (& sealed o))
                     (some multiname qname (= (& namespace qname) public namespace) :define-true))
            (note "Before trying to create a new dynamic property named " (:local qname)
                  ", check that there is no read-only fixed property with the same name.")
            (rwhen (and (in (find-base-instance-property (object-type o) (list-set qname) read) (tag none))
                        (in (find-archetype-property o (list-set qname) read true) (tag none)))
              (create-dynamic-property o qname false true new-value)
              (return ok)))
          (return none))
        (:narrow singleton-property
          (write-singleton-property m new-value phase)
          (return ok))
        (:narrow instance-property
          (rwhen (or (not-in o class :narrow-false) (in env (tag none) :narrow-false))
            (throw-error -reference-error "cannot write an instance property without supplying an instance"))
          (const this object (read-implicit-this env))
          (write-instance-property this (object-type this) m new-value phase)
          (return ok))))
    
    
    (%text :comment "The caller must make sure that the created property does not already exist and does not conflict with any other property.")
    (define (create-dynamic-property (o (union simple-instance date reg-exp package)) (qname qualified-name) (sealed boolean) (enumerable boolean) (new-value object))
            void
      (const dv dynamic-var (new dynamic-var new-value sealed))
      (&= local-bindings o (set+ (& local-bindings o) (list-set (new local-binding qname read-write false enumerable dv)))))
    

    (define (write-instance-property (this object) (c class) (m-base instance-property) (new-value object) (phase (tag run)))
            void
      (const m instance-property (get-derived-instance-property c m-base write))
      (case m
        (:narrow instance-variable
          (const s slot (find-slot this m))
          (const coerced-value object (coerce new-value (&opt type m)))
          (rwhen (and (& immutable m) (not-in (& value s) (tag none)))
            (throw-error -reference-error "cannot initialise a " (:character-literal "const") " instance variable twice"))
          (&= value s coerced-value))
        (:select instance-method
          (throw-error -reference-error "cannot write to an instance method"))
        (:narrow instance-getter
          (bottom (:local m) " cannot be an " (:type instance-getter) " because these are only represented as read-only properties."))
        (:narrow instance-setter
          ((& call m) this new-value phase))))
    
    
    (define (write-singleton-property (m singleton-property) (new-value object) (phase (tag run))) void
      (case m
        (:select (tag forbidden)
          (throw-error -reference-error "cannot access a property defined in a scope outside the current region if any block inside the current region shadows it"))
        (:narrow variable (exec (write-variable m new-value false)))
        (:narrow dynamic-var
          (&= value m new-value))
        (:narrow getter
          (bottom (:local m) " cannot be a " (:type getter) " because these are only represented as read-only properties."))
        (:narrow setter
          (const env environment-opt (& env m))
          (assert (not-in env (tag none) :narrow-true)
            "All instances are resolved for the " (:tag run) " phase, so " (:assertion) ".")
          ((& call m) new-value env phase))))
    
    
    (%heading (2 :semantics) "Deleting")
    (%text :comment "If " (:local r) " is a " (:type reference) ", " (:global-call delete-reference r) " deletes it. If "
           (:local r) " is an " (:type object) ", this function signals an error in strict mode or returns " (:tag true) " in non-strict mode. "
           (:global delete-reference) " is never called from a constant expression.")
    (define (delete-reference (r obj-or-ref) (strict boolean) (phase (tag run))) boolean
      (var result boolean-opt)
      (case r
        (:select object
          (if strict
            (throw-error -reference-error "a non-reference is not a valid target for " (:character-literal "delete") " in strict mode")
            (<- result true)))
        (:narrow lexical-reference
          (<- result (lexical-delete (& env r) (& variable-multiname r) phase)))
        (:narrow dot-reference
          (<- result ((& delete (& limit r)) (& base r) (& limit r) (& multiname r) none phase)))
        (:narrow bracket-reference
          (<- result ((& bracket-delete (& limit r)) (& base r) (& limit r) (& args r) phase))))
      (if (not-in result (tag none) :narrow-true)
        (return result)
        (return true)))
    
    
    (define (ordinary-bracket-delete (o object) (limit class) (args (vector object)) (phase (tag run))) boolean-opt
      (rwhen (/= (length args) 1)
        (throw-error -argument-error "exactly one argument must be supplied"))
      (const qname qualified-name (object-to-qualified-name (nth args 0) phase))
      (return ((& delete limit) o limit (list-set qname) none phase)))
    
    
    (define (lexical-delete (env environment) (multiname multiname) (phase (tag run))) boolean
      (var i integer 0)
      (while (< i (length env))
        (const frame frame (nth env i))
        (var result boolean-opt none)
        (case frame
          (:narrow (union package class)
            (const limit class (object-type frame))
            (<- result ((& delete limit) frame limit multiname env phase)))
          (:narrow (union parameter-frame local-frame)
            (when (not-in (find-local-singleton-property frame multiname write) (tag none))
              (<- result false)))
          (:narrow with-frame
            (const value object-opt (& value frame))
            (rwhen (in value (tag none) :narrow-false)
              (throw-error -uninitialized-error
                "cannot read a " (:character-literal "with") " statement" :apostrophe "s frame before that statement" :apostrophe
                "s expression has been evaluated"))
            (const limit class (object-type value))
            (<- result ((& delete limit) value limit multiname env phase))))
        (rwhen (not-in result (tag none) :narrow-true)
          (return result))
        (<- i (+ i 1)))
      (return true))
    
    
    (define (ordinary-delete (o object) (limit class) (multiname multiname) (env environment-opt) (phase (tag run) :unused))
            boolean-opt
      (rwhen (not-in (find-base-instance-property limit multiname write) (tag none))
        (return false))
      (rwhen (/= limit (object-type o) class)
        (return none))
      (const m property-opt (find-archetype-property o multiname write true))
      (case m
        (:select (tag none) (return none))
        (:select (tag forbidden)
          (throw-error -reference-error "cannot access a property defined in a scope outside the current region if any block inside the current region shadows it"))
        (:select (union variable getter setter) (return false))
        (:narrow dynamic-var
          (cond
           ((& sealed m) (return false))
           (nil
            (&= local-bindings (assert-in o binding-object)
                (map (& local-bindings (assert-in o binding-object))
                     b b (or (set-not-in (& qname b) multiname) (/= (& content b) m singleton-property))))
            (return true))))
        (:narrow instance-property
          (rwhen (or (not-in o class :narrow-false) (in env (tag none) :narrow-false))
            (return false))
          (exec (read-implicit-this env))
          (return false))))
    
    
    (%heading (2 :semantics) "Enumerating")
    
    (define (ordinary-enumerate (o object)) (list-set object)
      (const e1 (list-set object) (enumerate-instance-properties (object-type o)))
      (const e2 (list-set object) (enumerate-archetype-properties o))
      (return (set+ e1 e2)))
    
    
    (define (enumerate-instance-properties (c class)) (list-set object)
      (var e (list-set object) (list-set-of object))
      (for-each (& instance-properties c) m
        (when (&opt enumerable m)
          (<- e (set+ e (map (&opt multiname m) qname (& id qname) (= (& namespace qname) public namespace))))))
      (const super class-opt (& super c))
      (if (in super (tag none) :narrow-false)
        (return e)
        (return (set+ e (enumerate-instance-properties super)))))
    
    
    (define (enumerate-archetype-properties (o object)) (list-set object)
      (var e (list-set object) (list-set-of object))
      (for-each (set+ (list-set o) (archetypes o)) a
        (when (in a binding-object :narrow-true)
          (<- e (set+ e (enumerate-singleton-properties a)))))
      (return e))
    
    
    (define (enumerate-singleton-properties (o binding-object)) (list-set object)
      (var e (list-set object) (list-set-of object))
      (for-each (& local-bindings o) b
        (when (and (& enumerable b) (= (& namespace (& qname b)) public namespace))
          (<- e (set+ e (list-set-of object (& id (& qname b)))))))
      (when (in o class :narrow-true)
        (const super class-opt (& super o))
        (when (not-in super (tag none) :narrow-true)
          (<- e (set+ e (enumerate-singleton-properties super)))))
      (return e))
    
    
    
    (%heading (2 :semantics) "Calling Instances")
    (define (call (this object) (a object) (args (vector object)) (phase phase)) object
      (case a
        (:select (union undefined null boolean general-number char16 string namespace compound-attribute date reg-exp package)
          (throw-error -type-error))
        (:narrow class
          (return ((& call a) this a args phase)))
        (:narrow simple-instance
          (const f (union (-> (object simple-instance (vector object) phase) object) (tag none)) (& call a))
          (rwhen (in f (tag none) :narrow-false)
            (throw-error -type-error))
          (return (f this a args phase)))
        (:narrow method-closure
          (const m instance-method (& method a))
          (return ((& call m) (& this a) args phase)))))
    
    
    (define (ordinary-call (this object :unused) (c class) (args (vector object)) (phase phase :unused)) object
      (note "This function can be used in a constant expression.")
      (rwhen (not (& complete c))
        (throw-error -constant-error "cannot call a class before its definition has been compiled"))
      (rwhen (/= (length args) 1)
        (throw-error -argument-error "exactly one argument must be supplied"))
      (return (coerce (nth args 0) c)))
    
    
    (define (same-as-construct (this object :unused) (c class) (args (vector object)) (phase phase)) object
      (return (construct c args phase)))
    
    
    (%heading (2 :semantics) "Creating Instances")
    (define (construct (a object) (args (vector object)) (phase phase)) object
      (case a
        (:select (union undefined null boolean general-number char16 string namespace compound-attribute method-closure date reg-exp package)
          (throw-error -type-error))
        (:narrow class
          (return ((& construct a) a args phase)))
        (:narrow simple-instance
          (const f (union (-> (simple-instance (vector object) phase) object) (tag none)) (& construct a))
          (rwhen (in f (tag none) :narrow-false)
            (throw-error -type-error))
          (return (f a args phase)))))
    
    
    (define (ordinary-construct (c class) (args (vector object)) (phase phase)) object
      (rwhen (not (& complete c))
        (throw-error -constant-error "cannot construct an instance of a class before its definition has been compiled"))
      (rwhen (in phase (tag compile) :narrow-false)
        (throw-error -constant-error "a class constructor call is not a constant expression because it evaluates to a new object each time it is evaluated"))
      (const this simple-instance (create-simple-instance c (&opt prototype c) none none none))
      (call-init this c args phase)
      (return this))
    
    
    (define (create-simple-instance (c class)
                                    (archetype object-opt)
                                    (call (union (-> (object simple-instance (vector object) phase) object) (tag none)))
                                    (construct (union (-> (simple-instance (vector object) phase) object) (tag none)))
                                    (env environment-opt))
            simple-instance
      (var slots (list-set slot) (list-set-of slot))
      (for-each (ancestors c) s
        (for-each (& instance-properties s) m
          (when (in m instance-variable :narrow-true)
            (const slot slot (new slot m (&opt default-value m)))
            (<- slots (set+ slots (list-set slot))))))
      (return (new simple-instance (list-set-of local-binding) archetype (not (& dynamic c)) c slots call construct env)))
    
    
    (define (call-init (this simple-instance) (c class-opt) (args (vector object)) (phase (tag run))) void
      (var init (union (-> (simple-instance (vector object) (tag run)) void) (tag none)) none)
      (when (not-in c (tag none) :narrow-true)
        (<- init (& init c)))
      (cond
       ((not-in init (tag none) :narrow-true) (init this args phase))
       (nil (rwhen (nonempty args)
              (throw-error -argument-error "the default constructor does not take any arguments")))))

    
    (%heading (2 :semantics) "Adding Local Definitions")
    (define (define-singleton-property (env environment) (id string) (namespaces (list-set namespace)) (override-mod override-modifier) (explicit boolean)
              (accesses access-set) (m singleton-property))
            multiname
      (const inner-frame non-with-frame (assert-not-in (nth env 0) with-frame))
      (rwhen (not-in override-mod (tag none))
        (throw-error -attribute-error "a local definition cannot have the " (:character-literal "override") " attribute"))
      (rwhen (and explicit (not-in inner-frame package))
        (throw-error -attribute-error "the " (:character-literal "explicit") " attribute can only be used at the top level of a package"))
      (var namespaces2 (list-set namespace) namespaces)
      (when (empty namespaces2)
        (<- namespaces2 (list-set public)))
      (const multiname multiname (map namespaces2 ns (new qualified-name ns id)))
      (const regional-env (vector frame) (get-regional-environment env))
      (rwhen (some (& local-bindings inner-frame) b (and (set-in (& qname b) multiname) (accesses-overlap (& accesses b) accesses)))
        (throw-error -definition-error "duplicate definition in the same scope"))
      (rwhen (and (in inner-frame class :narrow-true) (= id (& name inner-frame) string))
        (throw-error -definition-error "a " (:character-literal "static") " property of a class cannot have the same name as the class, regardless of the namespace"))
      (for-each (subseq regional-env 1) frame
        (rwhen (and (not-in frame with-frame :narrow-true)
                    (some (& local-bindings frame) b (and (set-in (& qname b) multiname) (accesses-overlap (& accesses b) accesses)
                                                          (not-in (& content b) (tag forbidden)))))
          (throw-error -definition-error "this definition would shadow a property defined in an outer scope within the same region")))
      (const new-bindings (list-set local-binding) (map multiname qname (new local-binding qname accesses explicit true m)))
      (&= local-bindings inner-frame (set+ (& local-bindings inner-frame) new-bindings))
      (note "Mark the bindings of " (:local multiname) " as " (:tag forbidden)
            " in all non-innermost frames in the current region if they haven" :apostrophe "t been marked as such already.")
      (const new-forbidden-bindings (list-set local-binding) (map multiname qname (new local-binding qname accesses true true forbidden)))
      (for-each (subseq regional-env 1) frame
        (assert (not-in frame class) "Since " (:assertion) " here, a " (:type class) " frame never gets a " (:tag forbidden) " binding.")
        (when (not-in frame with-frame :narrow-true)
          (&= local-bindings frame (set+ (& local-bindings frame) new-forbidden-bindings))))
      (return multiname))
      
    
    (%text :comment (:global-call define-hoisted-var env id initial-value) " defines a hoisted variable with the name " (:local id)
           " in the environment " (:local env) ". Hoisted variables are hoisted to the package or enclosing function scope. "
           "Multiple hoisted variables may be defined in the same scope, but they may not coexist with non-hoisted variables with the same name. "
           "A hoisted variable can be defined using either a " (:character-literal "var") " or a " (:character-literal "function") " statement. "
           "If it is defined using " (:character-literal "var") ", then " (:local initial-value) " is always " (:tag undefined)
           " (if the " (:character-literal "var") " statement has an initialiser, then the variable" :apostrophe "s value will be written later when the "
           (:character-literal "var") " statement is executed). "
           "If it is defined using " (:character-literal "function") ", then " (:local initial-value) " must be a function instance or open instance. "
           "A " (:character-literal "var") " hoisted variable may be hoisted into the " (:type parameter-frame)
           " if there is already a parameter with the same name; a " (:character-literal "function") " hoisted variable is never hoisted into the "
           (:type parameter-frame) " and will shadow a parameter with the same name for compatibility with ECMAScript Edition 3. "
           "If there are multiple " (:character-literal "function") " definitions, the initial value is the last " (:character-literal "function") " definition.")
    (define (define-hoisted-var (env environment) (id string) (initial-value (union object uninstantiated-function))) dynamic-var
      (const qname qualified-name (new qualified-name public id))
      (const regional-env (vector frame) (get-regional-environment env))
      (var regional-frame frame (nth regional-env (- (length regional-env) 1)))
      (assert (in regional-frame (union package parameter-frame) :narrow-true)
        (:local env) " is either a " (:type package) " or a " (:type parameter-frame)
        " because hoisting only occurs into package or function scope.")
      (var existing-bindings (list-set local-binding) (map (& local-bindings regional-frame) b b (= (& qname b) qname qualified-name)))
      (when (and (or (empty existing-bindings) (not-in initial-value (tag undefined)))
                 (in regional-frame parameter-frame) (>= (length regional-env) 2))
        (<- regional-frame (nth regional-env (- (length regional-env) 2)) :end-narrow)
        (<- existing-bindings (map (& local-bindings (assert-in regional-frame local-frame)) b b (= (& qname b) qname qualified-name))))
      (cond
       ((empty existing-bindings)
        (const v dynamic-var (new dynamic-var initial-value true))
        (&= local-bindings regional-frame (set+ (& local-bindings regional-frame) (list-set (new local-binding qname read-write false true v))))
        (return v))
       ((/= (length existing-bindings) 1)
        (throw-error -definition-error "a hoisted definition conflicts with a non-hoisted one"))
       (nil
        (const b local-binding (unique-elt-of existing-bindings))
        (const m singleton-property (& content b))
        (rwhen (or (not-in (& accesses b) (tag read-write)) (not-in m dynamic-var :narrow-false))
          (throw-error -definition-error "a hoisted definition conflicts with a non-hoisted one"))
        (note "At this point a hoisted binding of the same " (:character-literal "var") " already exists, so there is no need to create another one. "
              "Overwrite its initial value if the new definition is a " (:character-literal "function") " definition.")
        (when (not-in initial-value (tag undefined))
          (&= value m initial-value))
        (&= sealed m true)
        (&= local-bindings regional-frame (set- (& local-bindings regional-frame) (list-set b)))
        (&= local-bindings regional-frame (set+ (& local-bindings regional-frame) (list-set (set-field b enumerable true))))
        (return m))))
    
    
    (%heading (2 :semantics) "Adding Instance Definitions")
    
    (define (search-for-overrides (c class) (multiname multiname) (accesses access-set)) instance-property-opt
      (var m-base instance-property-opt none)
      (const s class-opt (& super c))
      (when (not-in s (tag none) :narrow-true)
        (for-each multiname qname
          (const m instance-property-opt (find-base-instance-property s (list-set qname) accesses))
          (cond
           ((in m-base (tag none) :narrow-false) (<- m-base m))
           ((and (not-in m (tag none) :narrow-true) (/= m m-base instance-property))
            (throw-error -definition-error "cannot override two separate superclass methods at the same time")))))
      (return m-base))
    
    
    (define (define-instance-property (c class) (cxt context) (id string) (namespaces (list-set namespace))
              (override-mod override-modifier) (explicit boolean) (m instance-property))
            instance-property-opt
      (rwhen explicit
        (throw-error -attribute-error "the " (:character-literal "explicit") " attribute can only be used at the top level of a package"))
      (const accesses access-set (instance-property-accesses m))
      (const requested-multiname multiname (map namespaces ns (new qualified-name ns id)))
      (const open-multiname multiname (map (& open-namespaces cxt) ns (new qualified-name ns id)))
      (var defined-multiname multiname)
      (var searched-multiname multiname)
      (cond
       ((empty requested-multiname)
        (<- defined-multiname (list-set (new qualified-name public id)))
        (<- searched-multiname open-multiname)
        (assert (set<= defined-multiname searched-multiname multiname) (:assertion) " because the " (:character-literal "public") " namespace is always open."))
       (nil
        (<- defined-multiname requested-multiname)
        (<- searched-multiname requested-multiname)))
      (const m-base instance-property-opt (search-for-overrides c searched-multiname accesses))
      (var m-overridden instance-property-opt none)
      (when (not-in m-base (tag none) :narrow-true)
        (<- m-overridden (get-derived-instance-property c m-base accesses))
        (quiet-assert (not-in m-overridden (tag none) :narrow-true))
        (<- defined-multiname (&opt multiname m-overridden))
        (rwhen (not (set<= requested-multiname defined-multiname multiname))
          (throw-error -definition-error "cannot extend the set of a property" :apostrophe "s namespaces when overriding it"))
        (var good-kind boolean)
        (case m
          (:select instance-variable (<- good-kind (in m-overridden instance-variable)))
          (:select instance-getter (<- good-kind (in m-overridden (union instance-variable instance-getter))))
          (:select instance-setter (<- good-kind (in m-overridden (union instance-variable instance-setter))))
          (:select instance-method (<- good-kind (in m-overridden instance-method))))
        (rwhen (not good-kind)
          (throw-error -definition-error
            "a method can override only another method, a variable can override only another variable, a getter can override only a getter or a variable, and "
            "a setter can override only a setter or a variable"))
        (rwhen (& final m-overridden)
          (throw-error -definition-error "cannot override a " (:character-literal "final") " property")))
      (rwhen (some (& instance-properties c) m2 (and (nonempty (set* (&opt multiname m2) defined-multiname)) (accesses-overlap (instance-property-accesses m2) accesses)))
        (throw-error -definition-error "duplicate definition in the same scope"))
      (case override-mod
        (:select (tag none)
          (rwhen (not-in m-base (tag none))
            (throw-error -definition-error
              "a definition that overrides a superclass" :apostrophe "s property must be marked with the " (:character-literal "override") " attribute"))
          (rwhen (not-in (search-for-overrides c open-multiname accesses) (tag none))
            (throw-error -definition-error
              "this definition is hidden by one in a superclass when accessed without a namespace qualifier; "
              "in the rare cases where this is intentional, use the " (:character-literal "override(false)") " attribute")))
        (:select (tag false)
          (rwhen (not-in m-base (tag none))
            (throw-error -definition-error
              "this definition is marked with " (:character-literal "override(false)") " but it overrides a superclass" :apostrophe "s property")))
        (:select (tag true)
          (rwhen (in m-base (tag none))
            (throw-error -definition-error
              "this definition is marked with " (:character-literal "override") " or " (:character-literal "override(true)")
              " but it doesn" :apostrophe "t override a superclass" :apostrophe "s property")))
        (:select (tag undefined)))
      (&const= multiname m defined-multiname)
      (&= instance-properties c (set+ (& instance-properties c) (list-set m)))
      (return m-overridden))
    
    
    (%heading (2 :semantics) "Instantiation")
    
    (define (instantiate-function (uf uninstantiated-function) (env environment)) simple-instance
      (const c class (& type uf))
      (const i simple-instance (create-simple-instance c (&opt prototype c) (& call uf) (& construct uf) env))
      (dot-write i (list-set (new qualified-name public "length")) (real-to-float64 (& length uf)) run)
      (when (= c -prototype-function class)
        (const prototype object (construct -object (vector-of object) run))
        (dot-write prototype (list-set (new qualified-name public "constructor")) i run)
        (dot-write i (list-set (new qualified-name public "prototype")) prototype run))
      (const instantiations (list-set simple-instance) (& instantiations uf))
      (when (nonempty instantiations)
        (// (:def-const i2 simple-instance) "Suppose that " (:global instantiate-function) " were to choose at its discretion some element " (:local i2) " of "
            (:local instantiations) ", assign " (:expr environment-opt (& env i2)) :nbsp :assign-10 :nbsp (:local env) ", and return " (:local i) ". "
            "If the behaviour of doing that assignment were observationally indistinguishable by the rest of the program from the behaviour of "
            "returning " (:local i) " without modifying " (:expr environment-opt (& env i2)) ", then the implementation may, but does not have to, "
            (:keyword return) :nbsp (:local i2) " now, discarding (or not even bothering to create) the value of " (:local i) ".")
        (note "The above rule allows an implementation to avoid creating a fresh closure each time a local function is instantiated if it can show that the "
              "closures would behave identically. This optimisation is not transparent to the programmer because the instantiations will be "
              (:character-literal "===") " to each other and share one set of "
              "properties (including the " (:character-literal "prototype") " property, if applicable) rather than each having its own. ECMAScript programs "
              "should not rely on this distinction."))
      (&= instantiations uf (set+ instantiations (list-set i)))
      (return i))
    
    
    (define (instantiate-property (m singleton-property) (env environment)) singleton-property
      (case m
        (:select (tag forbidden) (return m))
        (:narrow variable
          (assert (in (& setup m) (tag none))
            (:assertion) " because " (:action setup) " must have been called on a frame before that frame can be instantiated.")
          (var value variable-value (& value m))
          (when (in value uninstantiated-function :narrow-true)
            (<- value (instantiate-function value env) :end-narrow))
          (return (new variable (&opt type m) value (& immutable m) none (& initializer m) env)))
        (:narrow dynamic-var
          (var value (union object uninstantiated-function) (& value m))
          (when (in value uninstantiated-function :narrow-true)
            (<- value (instantiate-function value env) :end-narrow))
          (return (new dynamic-var value (& sealed m))))
        (:narrow getter
          (case (& env m)
            (:select environment (return m))
            (:select (tag none) (return (new getter (& call m) env)))))
        (:narrow setter
          (case (& env m)
            (:select environment (return m))
            (:select (tag none) (return (new setter (& call m) env)))))))
    
    
    (deftuple property-translation
      (from singleton-property)
      (to singleton-property))
    
    (define (instantiate-local-frame (frame local-frame) (env environment))
            local-frame
      (const instantiated-frame local-frame (new local-frame (list-set-of local-binding)))
      (const properties (list-set singleton-property)
        (map (& local-bindings frame) b (& content b)))
      (const property-translations (list-set property-translation)
        (map properties m (new property-translation m (instantiate-property m (cons instantiated-frame env)))))
      (function (translate-property (m singleton-property)) singleton-property
        (const mi property-translation (unique-elt-of property-translations mi (= (& from mi) m singleton-property)))
        (return (& to mi)))
      (&= local-bindings instantiated-frame (map (& local-bindings frame) b (set-field b content (translate-property (& content b)))))
      (return instantiated-frame))
    
    
    (define (instantiate-parameter-frame (frame parameter-frame) (env environment) (singular-this object-opt))
            parameter-frame
      (assert (= (& superconstructor-called frame) (not-in (& kind frame) (tag constructor-function)) boolean)
        (:expr boolean (& superconstructor-called frame)) " must be " (:tag true) " if and only if "
        (:expr function-kind (& kind frame)) " is not " (:tag constructor-function) ".")
      (const instantiated-frame parameter-frame (new parameter-frame (list-set-of local-binding) (& kind frame) (& handling frame)
                                                     (& calls-superconstructor frame) (& superconstructor-called frame)
                                                     singular-this :uninit :uninit (&opt return-type frame)))
      (note (:local properties) " will contain the set of all " (:type singleton-property) " records found in the " (:local frame) ".")
      (var properties (list-set singleton-property)
        (map (& local-bindings frame) b (& content b)))
      (note "If any of the parameters (including the rest parameter) are anonymous, their bindings will not be present in "
            (:expr (list-set local-binding) (& local-bindings frame)) ". In this situation, the following steps add their "
            (:type singleton-property) " records to " (:local properties) ".")
      (for-each (&opt parameters frame) p
        (<- properties (set+ properties (list-set-of singleton-property (& var p)))))
      (const rest variable-opt (&opt rest frame))
      (when (not-in rest (tag none) :narrow-true)
        (<- properties (set+ properties (list-set-of singleton-property rest))))
      (const property-translations (list-set property-translation)
        (map properties m (new property-translation m (instantiate-property m (cons instantiated-frame env)))))
      (function (translate-property (m singleton-property)) singleton-property
        (const mi property-translation (unique-elt-of property-translations mi (= (& from mi) m singleton-property)))
        (return (& to mi)))
      (&= local-bindings instantiated-frame (map (& local-bindings frame) b (set-field b content (translate-property (& content b)))))
      (&= parameters instantiated-frame (map (&opt parameters frame) op
                                             (new parameter (assert-in (translate-property (& var op)) (union variable dynamic-var)) (& default op))))
      (if (in rest (tag none) :narrow-false)
        (&= rest instantiated-frame none)
        (&= rest instantiated-frame (assert-in (translate-property rest) variable)))
      (return instantiated-frame))
    
    
    
    (%heading (2 :semantics) "Sealing")
    
    (define (seal-object (o object)) void
      (when (in o (union simple-instance reg-exp date package) :narrow-true)
        (&= sealed o true)))
    
    
    (define (seal-all-local-properties (o object)) void
      (when (in o binding-object :narrow-true)
        (for-each (& local-bindings o) b
          (const m singleton-property (& content b))
          (when (in m dynamic-var :narrow-true)
            (&= sealed m true)))))
    
    
    (define (seal-local-property (o object) (qname qualified-name)) void
      (const c class (object-type o))
      (when (and (in (find-base-instance-property c (list-set qname) read) (tag none))
                 (in (find-base-instance-property c (list-set qname) write) (tag none))
                 (in o binding-object :narrow-true))
        (const matching-properties (list-set singleton-property) (map (& local-bindings o) b (& content b) (= (& qname b) qname qualified-name)))
        (for-each matching-properties m
          (when (in m dynamic-var :narrow-true)
            (&= sealed m true)))))
    
    
    
    (%heading (2 :semantics) "Standard Class Utilities")
    
    (define (default-arg (args (vector object)) (n integer) (default object)) object
      (rwhen (>= n (length args))
        (return default))
      (const arg object (nth args n))
      (if (in arg (tag undefined))
        (return default)
        (return arg)))
    
    
    (define (std-const-binding (qname qualified-name) (type (delay class)) (value object)) local-binding
      (return (new local-binding
                qname read-write false false
                (new variable type value true none none :uninit))))
    
    
    (define (std-explicit-const-binding (qname qualified-name) (type (delay class)) (value object)) local-binding
      (return (new local-binding
                qname read-write true false
                (new variable type value true none none :uninit))))
    
    
    (define (std-var-binding (qname qualified-name) (type (delay class)) (value object)) local-binding
      (return (new local-binding
                qname read-write false false
                (new variable type value false none none :uninit))))
    
    
    (define (std-function (qname qualified-name) (call (-> (object simple-instance (vector object) phase) object)) (length integer)) local-binding
      (const slots (list-set slot) (list-set (new slot ivar-function-length (real-to-float64 length))))
      (const f simple-instance (new simple-instance (list-set-of local-binding) (delay -function-prototype) true -function slots call none none))
      (return (new local-binding
                qname read-write false false
                (new variable -function f true none none :uninit))))
    
    
    (%text :comment (:global-call std-reserve qname archetype) " is used during the creation of system objects. It returns an alias of the local binding of "
           (:local qname) " in " (:local archetype)
           ", which should be the archetype of the object being created. The alias that " (:global std-reserve) " defines serves to prevent " (:local qname)
           " from being later redefined by users in the object being created while at the same time retaining the definition of " (:local qname)
           " that would normally be inherited from " (:local archetype) ".")
    (define (std-reserve (qname qualified-name) (archetype simple-instance)) local-binding
      (const matching-bindings (list-set local-binding) (map (& local-bindings archetype) b b (= (& qname b) qname qualified-name)))
      (return (unique-elt-of matching-bindings)))
     
    
    
    (%heading 1 "Expressions")
    (grammar-argument :beta allow-in no-in)
    
    
    (%heading (2 :semantics) "Terminal Actions")
    
    (declare-action name $identifier string :action nil
      (terminal-action name $identifier identity))
    (declare-action value $number general-number :action nil
      (terminal-action value $number identity))
    (declare-action value $string string :action nil
      (terminal-action value $string identity))
    (declare-action body $regular-expression string :action nil
      (terminal-action body $regular-expression first))
    (declare-action flags $regular-expression string :action nil
      (terminal-action flags $regular-expression second))
    (%print-actions)
    
    
    (%heading 2 "Identifiers")
    (rule :identifier ((name string))
      (production :identifier ($identifier) identifier-identifier (name (name $identifier)))
      (production :identifier (get) identifier-get (name "get"))
      (production :identifier (set) identifier-set (name "set"))
      (? js2 (production :identifier (include) identifier-include (name "include"))))
    (%print-actions)
    
    (%heading 2 "Qualified Identifiers")
    (rule :simple-qualified-identifier ((open-namespaces (writable-cell (list-set namespace)))
                                        (strict (writable-cell boolean))
                                        (validate (-> (context environment) void))
                                        (setup (-> () void))
                                        (eval (-> (environment phase) multiname)))
      (production :simple-qualified-identifier (:identifier) simple-qualified-identifier-identifier
        ((validate cxt (env :unused))
         (action<- (open-namespaces :simple-qualified-identifier 0) (& open-namespaces cxt))
         (action<- (strict :simple-qualified-identifier 0) (& strict cxt)))
        ((setup))
        ((eval (env :unused) (phase :unused))
         (return (map (open-namespaces :simple-qualified-identifier 0) ns (new qualified-name ns (name :identifier))))))
      (production :simple-qualified-identifier (:identifier \:\: :identifier) simple-qualified-identifier-identifier-qualifier
        ((validate cxt (env :unused))
         (action<- (open-namespaces :simple-qualified-identifier 0) (& open-namespaces cxt)))
        ((setup))
        ((eval env phase)
         (const multiname multiname (map (open-namespaces :simple-qualified-identifier 0) ns (new qualified-name ns (name :identifier 1))))
         (const a object (lexical-read env multiname phase))
         (rwhen (not-in a namespace :narrow-false)
           (throw-error -type-error "the qualifier must be a namespace"))
         (return (list-set (new qualified-name a (name :identifier 2))))))
      (production :simple-qualified-identifier (:reserved-namespace \:\: :identifier) simple-qualified-identifier-reserved-namespace-qualifier
        ((validate cxt env) ((validate :reserved-namespace) cxt env))
        ((setup) ((setup :reserved-namespace)))
        ((eval env phase)
         (const q namespace ((eval :reserved-namespace) env phase))
         (return (list-set (new qualified-name q (name :identifier)))))))
    
    (rule :expression-qualified-identifier ((strict (writable-cell boolean))
                                            (validate (-> (context environment) void))
                                            (setup (-> () void))
                                            (eval (-> (environment phase) multiname)))
      (production :expression-qualified-identifier (:paren-expression \:\: :identifier) expression-qualified-identifier-identifier
        ((validate cxt env)
         (action<- (strict :expression-qualified-identifier 0) (& strict cxt))
         ((validate :paren-expression) cxt env))
        ((setup) ((setup :paren-expression)))
        ((eval env phase)
         (const q object (read-reference ((eval :paren-expression) env phase) phase))
         (rwhen (not-in q namespace :narrow-false) (throw-error -type-error "the qualifier must be a namespace"))
         (return (list-set (new qualified-name q (name :identifier)))))))
    
    (rule :qualified-identifier ((strict (writable-cell boolean))
                                 (validate (-> (context environment) void))
                                 (setup (-> () void))
                                 (eval (-> (environment phase) multiname)))
      (production :qualified-identifier (:simple-qualified-identifier) qualified-identifier-simple
        ((validate cxt env)
         (action<- (strict :qualified-identifier 0) (& strict cxt))
         ((validate :simple-qualified-identifier) cxt env))
        ((setup) :forward)
        ((eval env phase) :forward-result))
      (production :qualified-identifier (:expression-qualified-identifier) qualified-identifier-expression
        ((validate cxt env)
         (action<- (strict :qualified-identifier 0) (& strict cxt))
         ((validate :expression-qualified-identifier) cxt env))
        ((setup) :forward)
        ((eval env phase) :forward-result)))
    (%print-actions ("Validation" open-namespaces strict validate) ("Setup" setup) ("Evaluation" eval))
    
    
    (%heading 2 "Primary Expressions")
    (rule :primary-expression ((validate (-> (context environment) void)) (setup (-> () void)) (eval (-> (environment phase) obj-or-ref)))
      (production :primary-expression (null) primary-expression-null
        ((validate (cxt :unused) (env :unused)))
        ((setup) :forward)
        ((eval (env :unused) (phase :unused)) (return null)))
      (production :primary-expression (true) primary-expression-true
        ((validate (cxt :unused) (env :unused)))
        ((setup) :forward)
        ((eval (env :unused) (phase :unused)) (return true)))
      (production :primary-expression (false) primary-expression-false
        ((validate (cxt :unused) (env :unused)))
        ((setup) :forward)
        ((eval (env :unused) (phase :unused)) (return false)))
      (production :primary-expression ($number) primary-expression-number
        ((validate (cxt :unused) (env :unused)))
        ((setup) :forward)
        ((eval (env :unused) (phase :unused)) (return (value $number))))
      (production :primary-expression ($string) primary-expression-string
        ((validate (cxt :unused) (env :unused)))
        ((setup) :forward)
        ((eval (env :unused) (phase :unused)) (return (value $string))))
      (production :primary-expression (this) primary-expression-this
        ((validate cxt env)
         (const frame parameter-frame-opt (get-enclosing-parameter-frame env))
         (cond
          ((in frame (tag none) :narrow-false)
           (rwhen (& strict cxt)
             (throw-error -syntax-error (:character-literal "this") " can be used outside a function only in non-strict mode")))
          ((in (& kind frame) (tag plain-function))
           (throw-error -syntax-error "this function does not define " (:character-literal "this")))))
        ((setup) :forward)
        ((eval env phase)
         (const frame parameter-frame-opt (get-enclosing-parameter-frame env))
         (rwhen (in frame (tag none) :narrow-false)
           (return (get-package-frame env)))
         (assert (not-in (& kind frame) (tag plain-function))
           (:action validate) " ensured that " (:assertion) " at this point.")
         (const this object-opt (& this frame))
         (rwhen (in this (tag none) :narrow-false)
           (assert (in phase (tag compile)) "If " (:action validate) " passed, " (:local this) " can be uninitialised only when " (:assertion) ".")
           (throw-error -constant-error "a constant expression cannot read an uninitialised " (:local this) " parameter"))
         (rwhen (not (& superconstructor-called frame))
           (throw-error -uninitialized-error "can" :apostrophe "t access " (:character-literal "this") " from within a constructor before the superconstructor has been called"))
         (return this)))
      (production :primary-expression ($regular-expression) primary-expression-regular-expression
        ((validate (cxt :unused) (env :unused)))
        ((setup) :forward)
        ((eval (env :unused) (phase :unused)) (return (append (body $regular-expression) "#" (flags $regular-expression))))) ;*****
      (production :primary-expression (:reserved-namespace) primary-expression-reserved-namespace
        ((validate cxt env) ((validate :reserved-namespace) cxt env))
        ((setup) :forward)
        ((eval env phase) (return ((eval :reserved-namespace) env phase))))
      (production :primary-expression (:paren-list-expression) primary-expression-paren-list-expression
        ((validate cxt env) ((validate :paren-list-expression) cxt env))
        ((setup) :forward)
        ((eval env phase) (return ((eval :paren-list-expression) env phase))))
      (production :primary-expression (:array-literal) primary-expression-array-literal
        ((validate cxt env) ((validate :array-literal) cxt env))
        ((setup) :forward)
        ((eval env phase) (return ((eval :array-literal) env phase))))
      (production :primary-expression (:object-literal) primary-expression-object-literal
        ((validate cxt env) ((validate :object-literal) cxt env))
        ((setup) :forward)
        ((eval env phase) (return ((eval :object-literal) env phase))))
      (production :primary-expression (:function-expression) primary-expression-function-expression
        ((validate cxt env) ((validate :function-expression) cxt env))
        ((setup) :forward)
        ((eval env phase) (return ((eval :function-expression) env phase)))))
    
    (rule :reserved-namespace ((validate (-> (context environment) void)) (setup (-> () void)) (eval (-> (environment phase) namespace)))
      (production :reserved-namespace (public) reserved-namespace-public
        ((validate (cxt :unused) (env :unused)))
        ((setup))
        ((eval (env :unused) (phase :unused)) (return public)))
      (production :reserved-namespace (private) reserved-namespace-private
        ((validate (cxt :unused) env)
         (rwhen (in (get-enclosing-class env) (tag none))
           (throw-error -syntax-error (:character-literal "private") " is meaningful only inside a class")))
        ((setup))
        ((eval env (phase :unused))
         (const c class-opt (get-enclosing-class env))
         (assert (not-in c (tag none) :narrow-true)
           (:action validate) " already ensured that " (:assertion) ".")
         (return (&opt private-namespace c)))))

    (rule :paren-expression ((validate (-> (context environment) void)) (setup (-> () void)) (eval (-> (environment phase) obj-or-ref)))
      (production :paren-expression (\( (:assignment-expression allow-in) \)) paren-expression-assignment-expression
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase) :forward-result)))
    
    (rule :paren-list-expression ((validate (-> (context environment) void)) (setup (-> () void))
                                  (eval (-> (environment phase) obj-or-ref))
                                  (eval-as-list (-> (environment phase) (vector object))))
      (production :paren-list-expression (:paren-expression) paren-list-expression-paren-expression
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase) (return ((eval :paren-expression) env phase)))
        ((eval-as-list env phase)
         (const elt object (read-reference ((eval :paren-expression) env phase) phase))
         (return (vector elt))))
      (production :paren-list-expression (\( (:list-expression allow-in) \, (:assignment-expression allow-in) \)) paren-list-expression-list-expression
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (exec (read-reference ((eval :list-expression) env phase) phase))
         (return (read-reference ((eval :assignment-expression) env phase) phase)))
        ((eval-as-list env phase)
         (const elts (vector object) ((eval-as-list :list-expression) env phase))
         (const elt object (read-reference ((eval :assignment-expression) env phase) phase))
         (return (append elts (vector elt))))))
    (%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
    
    
    (%heading 2 "Function Expressions")
    (rule :function-expression ((f (writable-cell uninstantiated-function))
                                (validate (-> (context environment) void))
                                (setup (-> () void))
                                (eval (-> (environment phase) obj-or-ref)))
      (production :function-expression (function :function-common) function-expression-anonymous
        ((validate cxt env)
         (var kind static-function-kind plain-function)
         (when (and (not (& strict cxt)) (plain :function-common))
           (<- kind unchecked-function))
         (action<- (f :function-expression 0) ((validate-static-function :function-common) cxt env kind)))
        ((setup) ((setup :function-common)))
        ((eval env phase)
         (rwhen (in phase (tag compile))
           (throw-error -constant-error "a " (:character-literal "function") " expression is not a constant expression because it can evaluate to different values"))
         (return (instantiate-function (f :function-expression 0) env))))
      (production :function-expression (function :identifier :function-common) function-expression-named
        ((validate cxt env)
         (const v variable (new variable -function none true none busy :uninit))
         (const b local-binding (new local-binding (new qualified-name public (name :identifier)) read-write false true v))
         (const compile-frame local-frame (new local-frame (list-set b)))
         (var kind static-function-kind plain-function)
         (when (and (not (& strict cxt)) (plain :function-common))
           (<- kind unchecked-function))
         (action<- (f :function-expression 0) ((validate-static-function :function-common) cxt (cons compile-frame env) kind)))
        ((setup) ((setup :function-common)))
        ((eval env phase)
         (rwhen (in phase (tag compile))
           (throw-error -constant-error "a " (:character-literal "function") " expression is not a constant expression because it can evaluate to different values"))
         (const v variable (new variable -function none true none none :uninit))
         (const b local-binding (new local-binding (new qualified-name public (name :identifier)) read-write false true v))
         (const runtime-frame local-frame (new local-frame (list-set b)))
         (const f simple-instance (instantiate-function (f :function-expression 0) (cons runtime-frame env)))
         (&= value v f)
         (return f))))
    (%print-actions ("Validation" f validate) ("Setup" setup) ("Evaluation" eval))
    
    
    (%heading 2 "Object Literals")
    (rule :object-literal ((validate (-> (context environment) void)) (setup (-> () void))
                           (eval (-> (environment phase) obj-or-ref)))
      (production :object-literal (\{ :field-list \}) object-literal-list
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (rwhen (in phase (tag compile) :narrow-false)
           (throw-error -constant-error "an object literal is not a constant expression because it evaluates to a new object each time it is evaluated"))
         (const o object (construct -object (vector-of object) phase))
         ((eval :field-list) env o phase)
         (return o))))
    
    
    (rule :field-list ((validate (-> (context environment) void)) (setup (-> () void))
                       (eval (-> (environment object (tag run)) void)))
      (production :field-list () field-list-empty
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env o phase) :forward))
      (production :field-list (:nonempty-field-list) field-list-nonempty
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env o phase) :forward)))
    
    
    (rule :nonempty-field-list ((validate (-> (context environment) void)) (setup (-> () void))
                                (eval (-> (environment object (tag run)) void)))
      (production :nonempty-field-list (:literal-field) nonempty-field-list-one
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env o phase) :forward))
      (production :nonempty-field-list (:literal-field \, :nonempty-field-list) nonempty-field-list-more
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env o phase) :forward)))
    
    
    (rule :literal-field ((validate (-> (context environment) void))
                          (setup (-> () void))
                          (eval (-> (environment object (tag run)) void)))
      (production :literal-field (:field-name \: (:assignment-expression allow-in)) literal-field-assignment-expression
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env o phase)
         (const multiname multiname ((eval :field-name) env phase))
         (const value object (read-reference ((eval :assignment-expression) env phase) phase))
         (dot-write o multiname value phase))))
    
    
    (rule :field-name ((validate (-> (context environment) void)) (setup (-> () void))
                       (eval (-> (environment phase) multiname)))
      (production :field-name (:qualified-identifier) field-name-identifier
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase) (return ((eval :qualified-identifier) env phase))))
      (production :field-name ($string) field-name-string
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval (env :unused) phase) (return (list-set (object-to-qualified-name (value $string) phase)))))
      (production :field-name ($number) field-name-number
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval (env :unused) phase) (return (list-set (object-to-qualified-name (value $number) phase)))))
      (production :field-name (:paren-expression) field-name-paren-expression
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :paren-expression) env phase) phase))
         (return (list-set (object-to-qualified-name a phase))))))
    (%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
    
    
    (%heading 2 "Array Literals")
    (rule :array-literal ((validate (-> (context environment) void)) (setup (-> () void))
                          (eval (-> (environment phase) obj-or-ref)))
      (production :array-literal ([ :element-list ]) array-literal-list
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (rwhen (in phase (tag compile) :narrow-false)
           (throw-error -constant-error "an array literal is not a constant expression because it evaluates to a new object each time it is evaluated"))
         (const o object (construct -array (vector-of object) phase))
         (const length integer ((eval :element-list) env 0 o phase))
         (write-array-private-length o length phase)
         (return o))))
    
    
    (rule :element-list ((validate (-> (context environment) void)) (setup (-> () void))
                         (eval (-> (environment integer object (tag run)) integer)))
      (production :element-list () element-list-none
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval (env :unused) length (o :unused) (phase :unused)) (return length)))
      (production :element-list (:literal-element) element-list-one
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env length o phase)
         ((eval :literal-element) env length o phase)
         (return (+ length 1))))
      (production :element-list (\, :element-list) element-list-hole
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env length o phase)
         (return ((eval :element-list) env (+ length 1) o phase))))
      (production :element-list (:literal-element \, :element-list) element-list-more
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env length o phase)
         ((eval :literal-element) env length o phase)
         (return ((eval :element-list) env (+ length 1) o phase)))))
    
    
    (rule :literal-element ((validate (-> (context environment) void))
                            (setup (-> () void))
                            (eval (-> (environment integer object (tag run)) void)))
      (production :literal-element ((:assignment-expression allow-in)) literal-element-assignment-expression
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env length o phase)
         (const value object (read-reference ((eval :assignment-expression) env phase) phase))
         (index-write o length value phase))))
    (%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
    
    
    (%heading 2 "Super Expressions")
    (rule :super-expression ((validate (-> (context environment) void)) (setup (-> () void))
                             (eval (-> (environment phase) obj-optional-limit)))
      (production :super-expression (super) super-expression-super
        ((validate (cxt :unused) env)
         (const c class-opt (get-enclosing-class env))
         (rwhen (in c (tag none) :narrow-false)
           (throw-error -syntax-error "a " (:character-literal "super") " expression is meaningful only inside a class"))
         (const frame parameter-frame-opt (get-enclosing-parameter-frame env))
         (rwhen (or (in frame (tag none) :narrow-false) (in (& kind frame) static-function-kind))
           (throw-error -syntax-error "a " (:character-literal "super") " expression without an argument is meaningful only inside an instance method or a constructor"))
         (rwhen (in (& super c) (tag none))
           (throw-error -syntax-error "a " (:character-literal "super") " expression is meaningful only if the enclosing class has a superclass")))
        ((setup) :forward)
        ((eval env phase)
         (const frame parameter-frame-opt (get-enclosing-parameter-frame env))
         (assert (and (not-in frame (tag none) :narrow-true) (not-in (& kind frame) static-function-kind))
           (:action validate) " ensured that " (:assertion) " at this point.")
         (const this object-opt (& this frame))
         (rwhen (in this (tag none) :narrow-false)
           (assert (in phase (tag compile)) "If " (:action validate) " passed, " (:local this) " can be uninitialised only when " (:assertion) ".")
           (throw-error -constant-error "a constant expression cannot read an uninitialised " (:local this) " parameter"))
         (rwhen (not (& superconstructor-called frame))
           (throw-error -uninitialized-error "can" :apostrophe "t access " (:character-literal "super") " from within a constructor before the superconstructor has been called"))
         (return (make-limited-instance this (assert-not-in (get-enclosing-class env) (tag none)) phase))))
      (production :super-expression (super :paren-expression) super-expression-super-paren-expression
        ((validate cxt env)
         (const c class-opt (get-enclosing-class env))
         (rwhen (in c (tag none) :narrow-false)
           (throw-error -syntax-error "a " (:character-literal "super") " expression is meaningful only inside a class"))
         (rwhen (in (& super c) (tag none))
           (throw-error -syntax-error "a " (:character-literal "super") " expression is meaningful only if the enclosing class has a superclass"))
         ((validate :paren-expression) cxt env))
        ((setup) :forward)
        ((eval env phase)
         (const r obj-or-ref ((eval :paren-expression) env phase))
         (return (make-limited-instance r (assert-not-in (get-enclosing-class env) (tag none)) phase)))))
    (%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
    
    
    (define (make-limited-instance (r obj-or-ref) (c class) (phase phase)) obj-optional-limit
      (const o object (read-reference r phase))
      (const limit class-opt (& super c))
      (assert (not-in limit (tag none) :narrow-true)
        (:action validate) " ensured that " (:local limit) " cannot be " (:tag none) " at this point.")
      (const coerced object (coerce o limit))
      (rwhen (in coerced (tag null))
        (return null))
      (return (new limited-instance coerced limit)))
    
    
    (%heading 2 "Postfix Expressions")
    (rule :postfix-expression ((validate (-> (context environment) void)) (setup (-> () void))
                               (eval (-> (environment phase) obj-or-ref)))
      (production :postfix-expression (:attribute-expression) postfix-expression-attribute-expression
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase) :forward-result))
      (production :postfix-expression (:full-postfix-expression) postfix-expression-full-postfix-expression
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase) :forward-result))
      (production :postfix-expression (:short-new-expression) postfix-expression-short-new-expression
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase) :forward-result)))
    
    (rule :attribute-expression ((validate (-> (context environment) void)) (setup (-> () void))
                                 (eval (-> (environment phase) obj-or-ref)))
      (production :attribute-expression (:simple-qualified-identifier) attribute-expression-simple-qualified-identifier
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const m multiname ((eval :simple-qualified-identifier) env phase))
         (return (new lexical-reference env m (strict :simple-qualified-identifier)))))
      (production :attribute-expression (:attribute-expression :property-operator) attribute-expression-property-operator
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :attribute-expression) env phase) phase))
         (return ((eval :property-operator) env a phase))))
      (production :attribute-expression (:attribute-expression :arguments) attribute-expression-call
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const r obj-or-ref ((eval :attribute-expression) env phase))
         (const f object (read-reference r phase))
         (var base object)
         (case r
           (:select (union object lexical-reference) (<- base null))
           (:narrow (union dot-reference bracket-reference) (<- base (& base r))))
         (const args (vector object) ((eval :arguments) env phase))
         (return (call base f args phase)))))
    
    (rule :full-postfix-expression ((validate (-> (context environment) void)) (setup (-> () void))
                                    (eval (-> (environment phase) obj-or-ref)))
      (production :full-postfix-expression (:primary-expression) full-postfix-expression-primary-expression
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase) (return ((eval :primary-expression) env phase))))
      (production :full-postfix-expression (:expression-qualified-identifier) full-postfix-expression-expression-qualified-identifier
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const m multiname ((eval :expression-qualified-identifier) env phase))
         (return (new lexical-reference env m (strict :expression-qualified-identifier)))))
      (production :full-postfix-expression (:full-new-expression) full-postfix-expression-full-new-expression
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase) (return ((eval :full-new-expression) env phase))))
      (production :full-postfix-expression (:full-postfix-expression :property-operator) full-postfix-expression-property-operator
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :full-postfix-expression) env phase) phase))
         (return ((eval :property-operator) env a phase))))
      (production :full-postfix-expression (:super-expression :property-operator) full-postfix-expression-super-property-operator
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const a obj-optional-limit ((eval :super-expression) env phase))
         (return ((eval :property-operator) env a phase))))
      (production :full-postfix-expression (:full-postfix-expression :arguments) full-postfix-expression-call
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const r obj-or-ref ((eval :full-postfix-expression) env phase))
         (const f object (read-reference r phase))
         (var base object)
         (case r
           (:select (union object lexical-reference) (<- base null))
           (:narrow (union dot-reference bracket-reference) (<- base (& base r))))
         (const args (vector object) ((eval :arguments) env phase))
         (return (call base f args phase))))
      (production :full-postfix-expression (:postfix-expression :no-line-break ++) full-postfix-expression-increment
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (rwhen (in phase (tag compile) :narrow-false)
           (throw-error -constant-error (:character-literal "++") " cannot be used in a constant expression"))
         (const r obj-or-ref ((eval :postfix-expression) env phase))
         (const a object (read-reference r phase))
         (const b object (plus a phase))
         (const c object (add b 1.0 phase))
         (write-reference r c phase)
         (return b)))
      (production :full-postfix-expression (:postfix-expression :no-line-break --) full-postfix-expression-decrement
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (rwhen (in phase (tag compile) :narrow-false)
           (throw-error -constant-error (:character-literal "--") " cannot be used in a constant expression"))
         (const r obj-or-ref ((eval :postfix-expression) env phase))
         (const a object (read-reference r phase))
         (const b object (plus a phase))
         (const c object (subtract b 1.0 phase))
         (write-reference r c phase)
         (return b))))
    
    (rule :full-new-expression ((validate (-> (context environment) void)) (setup (-> () void))
                                (eval (-> (environment phase) obj-or-ref)))
      (production :full-new-expression (new :full-new-subexpression :arguments) full-new-expression-new
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const f object (read-reference ((eval :full-new-subexpression) env phase) phase))
         (const args (vector object) ((eval :arguments) env phase))
         (return (construct f args phase)))))
    
    (rule :full-new-subexpression ((validate (-> (context environment) void)) (setup (-> () void))
                                   (eval (-> (environment phase) obj-or-ref)))
      (production :full-new-subexpression (:primary-expression) full-new-subexpression-primary-expression
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase) (return ((eval :primary-expression) env phase))))
      (production :full-new-subexpression (:qualified-identifier) full-new-subexpression-qualified-identifier
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const m multiname ((eval :qualified-identifier) env phase))
         (return (new lexical-reference env m (strict :qualified-identifier)))))
      (production :full-new-subexpression (:full-new-expression) full-new-subexpression-full-new-expression
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase) (return ((eval :full-new-expression) env phase))))
      (production :full-new-subexpression (:full-new-subexpression :property-operator) full-new-subexpression-property-operator
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :full-new-subexpression) env phase) phase))
         (return ((eval :property-operator) env a phase))))
      (production :full-new-subexpression (:super-expression :property-operator) full-new-subexpression-super-property-operator
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const a obj-optional-limit ((eval :super-expression) env phase))
         (return ((eval :property-operator) env a phase)))))
    
    (rule :short-new-expression ((validate (-> (context environment) void)) (setup (-> () void))
                                 (eval (-> (environment phase) obj-or-ref)))
      (production :short-new-expression (new :short-new-subexpression) short-new-expression-new
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const f object (read-reference ((eval :short-new-subexpression) env phase) phase))
         (return (construct f (vector-of object) phase)))))
    
    (rule :short-new-subexpression ((validate (-> (context environment) void)) (setup (-> () void))
                                    (eval (-> (environment phase) obj-or-ref)))
      (production :short-new-subexpression (:full-new-subexpression) short-new-subexpression-new-full
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase) :forward-result))
      (production :short-new-subexpression (:short-new-expression) short-new-subexpression-new-short
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase) :forward-result)))
    (%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
    
    
    (%heading 2 "Property Operators")
    (rule :property-operator ((validate (-> (context environment) void)) (setup (-> () void))
                              (eval (-> (environment obj-optional-limit phase) obj-or-ref)))
      (production :property-operator (\. :qualified-identifier) property-operator-qualified-identifier
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env base phase)
         (const m multiname ((eval :qualified-identifier) env phase))
         (case base
           (:narrow object (return (new dot-reference base (object-type base) m)))
           (:narrow limited-instance (return (new dot-reference (& instance base) (& limit base) m))))))
      (production :property-operator (:brackets) property-operator-brackets
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env base phase)
         (const args (vector object) ((eval :brackets) env phase))
         (case base
           (:narrow object (return (new bracket-reference base (object-type base) args)))
           (:narrow limited-instance (return (new bracket-reference (& instance base) (& limit base) args)))))))
    
    (rule :brackets ((validate (-> (context environment) void)) (setup (-> () void))
                     (eval (-> (environment phase) (vector object))))
      (production :brackets ([ ]) brackets-none
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval (env :unused) (phase :unused)) (return (vector-of object))))
      (production :brackets ([ (:list-expression allow-in) ]) brackets-some
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase) (return ((eval-as-list :list-expression) env phase))))
      (production :brackets ([ :expressions-with-rest ]) brackets-rest
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase) (return ((eval :expressions-with-rest) env phase)))))
    
    (rule :arguments ((validate (-> (context environment) void)) (setup (-> () void))
                      (eval (-> (environment phase) (vector object))))
      (production :arguments (\( \)) arguments-none
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval (env :unused) (phase :unused)) (return (vector-of object))))
      (production :arguments (:paren-list-expression) arguments-some
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase) (return ((eval-as-list :paren-list-expression) env phase))))
      (production :arguments (\( :expressions-with-rest \)) arguments-rest
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase) (return ((eval :expressions-with-rest) env phase)))))
    
    (rule :expressions-with-rest ((validate (-> (context environment) void)) (setup (-> () void))
                                  (eval (-> (environment phase) (vector object))))
      (production :expressions-with-rest (:rest-expression) expressions-with-rest-one
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase) (return ((eval :rest-expression) env phase))))
      (production :expressions-with-rest ((:list-expression allow-in) \, :rest-expression) expressions-with-rest-more
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const args1 (vector object) ((eval-as-list :list-expression) env phase))
         (const args2 (vector object) ((eval :rest-expression) env phase))
         (return (append args1 args2)))))
    
    (rule :rest-expression ((validate (-> (context environment) void)) (setup (-> () void))
                            (eval (-> (environment phase) (vector object))))
      (production :rest-expression (\.\.\. (:assignment-expression allow-in)) rest-expression-one
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :assignment-expression) env phase) phase))
         (const length integer (read-length a phase))
         (var i integer 0)
         (var args (vector object) (vector-of object))
         (while (/= i length)
           (const arg object-opt (index-read a i phase))
           (rwhen (in arg (tag none) :narrow-false)
             (/* "An implementation may, at its discretion, either " (:keyword throw) " a " (:global -reference-error)
                 " or treat the hole as a missing argument, substituting the called function" :apostrophe "s default parameter value if there is one, "
                 (:tag undefined) " if the called function is unchecked, or " (:keyword throw) "ing an " (:global -argument-error) " exception otherwise. "
                 "An implementation must not replace such a hole with " (:tag undefined) " except when the called function is unchecked or happens to "
                 "have " (:tag undefined) " as its default parameter value.")
             (throw-error -reference-error))
           (<- args (append args (vector arg)))
           (<- i (+ i 1)))
         (return args))))
    (%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
    
    
    (%heading 2 "Unary Operators")
    (rule :unary-expression ((strict (writable-cell boolean))
                             (validate (-> (context environment) void)) (setup (-> () void))
                             (eval (-> (environment phase) obj-or-ref)))
      (production :unary-expression (:postfix-expression) unary-expression-postfix
        ((validate cxt env) ((validate :postfix-expression) cxt env))
        ((setup) :forward)
        ((eval env phase) (return ((eval :postfix-expression) env phase))))
      (production :unary-expression (delete :postfix-expression) unary-expression-delete
        ((validate cxt env)
         ((validate :postfix-expression) cxt env)
         (action<- (strict :unary-expression 0) (& strict cxt)))
        ((setup) :forward)
        ((eval env phase)
         (rwhen (in phase (tag compile) :narrow-false)
           (throw-error -constant-error (:character-literal "delete") " cannot be used in a constant expression"))
         (const r obj-or-ref ((eval :postfix-expression) env phase))
         (return (delete-reference r (strict :unary-expression 0) phase))))
      (production :unary-expression (void :unary-expression) unary-expression-void
        ((validate cxt env) ((validate :unary-expression) cxt env))
        ((setup) :forward)
        ((eval env phase)
         (exec (read-reference ((eval :unary-expression) env phase) phase))
         (return undefined)))
      (production :unary-expression (typeof :unary-expression) unary-expression-typeof
        ((validate cxt env) ((validate :unary-expression) cxt env))
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :unary-expression) env phase) phase))
         (const c class (object-type a))
         (return (& typeof-string c))))
      (production :unary-expression (++ :postfix-expression) unary-expression-increment
        ((validate cxt env) ((validate :postfix-expression) cxt env))
        ((setup) :forward)
        ((eval env phase)
         (rwhen (in phase (tag compile) :narrow-false)
           (throw-error -constant-error (:character-literal "++") " cannot be used in a constant expression"))
         (const r obj-or-ref ((eval :postfix-expression) env phase))
         (const a object (read-reference r phase))
         (const b object (plus a phase))
         (const c object (add b 1.0 phase))
         (write-reference r c phase)
         (return c)))
      (production :unary-expression (-- :postfix-expression) unary-expression-decrement
        ((validate cxt env) ((validate :postfix-expression) cxt env))
        ((setup) :forward)
        ((eval env phase)
         (rwhen (in phase (tag compile) :narrow-false)
           (throw-error -constant-error (:character-literal "--") " cannot be used in a constant expression"))
         (const r obj-or-ref ((eval :postfix-expression) env phase))
         (const a object (read-reference r phase))
         (const b object (plus a phase))
         (const c object (subtract b 1.0 phase))
         (write-reference r c phase)
         (return c)))
      (production :unary-expression (+ :unary-expression) unary-expression-plus
        ((validate cxt env) ((validate :unary-expression) cxt env))
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :unary-expression) env phase) phase))
         (return (plus a phase))))
      (production :unary-expression (- :unary-expression) unary-expression-minus
        ((validate cxt env) ((validate :unary-expression) cxt env))
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :unary-expression) env phase) phase))
         (return (minus a phase))))
      (production :unary-expression (- $negated-min-long) unary-expression-min-long
        ((validate (cxt :unused) (env :unused)))
        ((setup) :forward)
        ((eval (env :unused) (phase :unused))
         (return (new long (neg (expt 2 63))))))
      (production :unary-expression (~ :unary-expression) unary-expression-bitwise-not
        ((validate cxt env) ((validate :unary-expression) cxt env))
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :unary-expression) env phase) phase))
         (return (bit-not a phase))))
      (production :unary-expression (! :unary-expression) unary-expression-logical-not
        ((validate cxt env) ((validate :unary-expression) cxt env))
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :unary-expression) env phase) phase))
         (return (logical-not a phase)))))
    (%print-actions ("Validation" strict validate) ("Setup" setup) ("Evaluation" eval))
    
    
    (%text :comment (:global-call plus a phase) " returns the value of the unary expression " (:character-literal "+") (:local a) ". If "
           (:local phase) " is " (:tag compile) ", only constant operations are permitted.")
    (define (plus (a object) (phase phase)) object
      (return (object-to-general-number a phase)))
    
    (%text :comment (:global-call minus a phase) " returns the value of the unary expression " (:character-literal "-") (:local a) ". If "
           (:local phase) " is " (:tag compile) ", only constant operations are permitted.")
    (define (minus (a object) (phase phase)) object
      (const x general-number (object-to-general-number a phase))
      (return (general-number-negate x)))
    
    (define (general-number-negate (x general-number)) general-number
      (case x
        (:narrow long (return (integer-to-long (neg (& value x)))))
        (:narrow u-long (return (integer-to-u-long (neg (& value x)))))
        (:narrow float32 (return (float32-negate x)))
        (:narrow float64 (return (float64-negate x)))))
    
    (define (bit-not (a object) (phase phase)) object
      (const x general-number (object-to-general-number a phase))
      (case x
        (:narrow long
          (const i (integer-range (neg (expt 2 63)) (- (expt 2 63) 1)) (& value x))
          (return (new long (bitwise-xor i -1))))
        (:narrow u-long
          (const i (integer-range 0 (- (expt 2 64) 1)) (& value x))
          (return (new u-long (bitwise-xor i (hex #xFFFFFFFFFFFFFFFF)))))
        (:narrow (union float32 float64)
          (const i (integer-range (neg (expt 2 31)) (- (expt 2 31) 1)) (signed-wrap32 (truncate-to-integer x)))
          (return (real-to-float64 (bitwise-xor i -1))))))
    
    (%text :comment (:global-call logical-not a phase) " returns the value of the unary expression " (:character-literal "!") (:local a) ". If "
           (:local phase) " is " (:tag compile) ", only constant operations are permitted.")
    (define (logical-not (a object) (phase phase :unused)) object
      (return (not (object-to-boolean a))))
    
        
    (%heading 2 "Multiplicative Operators")
    (rule :multiplicative-expression ((validate (-> (context environment) void)) (setup (-> () void))
                                      (eval (-> (environment phase) obj-or-ref)))
      (production :multiplicative-expression (:unary-expression) multiplicative-expression-unary
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase) (return ((eval :unary-expression) env phase))))
      (production :multiplicative-expression (:multiplicative-expression * :unary-expression) multiplicative-expression-multiply
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :multiplicative-expression) env phase) phase))
         (const b object (read-reference ((eval :unary-expression) env phase) phase))
         (return (multiply a b phase))))
      (production :multiplicative-expression (:multiplicative-expression / :unary-expression) multiplicative-expression-divide
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :multiplicative-expression) env phase) phase))
         (const b object (read-reference ((eval :unary-expression) env phase) phase))
         (return (divide a b phase))))
      (production :multiplicative-expression (:multiplicative-expression % :unary-expression) multiplicative-expression-remainder
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :multiplicative-expression) env phase) phase))
         (const b object (read-reference ((eval :unary-expression) env phase) phase))
         (return (remainder a b phase)))))
    (%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
    
    (define (multiply (a object) (b object) (phase phase)) object
      (const x general-number (object-to-general-number a phase))
      (const y general-number (object-to-general-number b phase))
      (when (or (in x (union long u-long)) (in y (union long u-long)))
        (const i integer-opt (check-integer x))
        (const j integer-opt (check-integer y))
        (rwhen (and (not-in i (tag none) :narrow-true) (not-in j (tag none) :narrow-true))
          (const k integer (* i j))
          (if (or (in x u-long) (in y u-long))
            (return (integer-to-u-long k))
            (return (integer-to-long k)))))
      (return (float64-multiply (to-float64 x) (to-float64 y))))
    
    (define (divide (a object) (b object) (phase phase)) object
      (const x general-number (object-to-general-number a phase))
      (const y general-number (object-to-general-number b phase))
      (when (or (in x (union long u-long)) (in y (union long u-long)))
        (const i integer-opt (check-integer x))
        (const j integer-opt (check-integer y))
        (rwhen (and (not-in i (tag none) :narrow-true) (not-in j (tag none) :narrow-true) (/= j 0))
          (const q rational (rat/ i j))
          (if (or (in x u-long) (in y u-long))
            (return (rational-to-u-long q))
            (return (rational-to-long q)))))
      (return (float64-divide (to-float64 x) (to-float64 y))))
    
    (define (remainder (a object) (b object) (phase phase)) object
      (const x general-number (object-to-general-number a phase))
      (const y general-number (object-to-general-number b phase))
      (when (or (in x (union long u-long)) (in y (union long u-long)))
        (const i integer-opt (check-integer x))
        (const j integer-opt (check-integer y))
        (rwhen (and (not-in i (tag none) :narrow-true) (not-in j (tag none) :narrow-true) (/= j 0))
          (const q rational (rat/ i j))
          (const k integer (if (>= q 0 rational) (floor q) (ceiling q)))
          (const r integer (- i (* j k)))
          (if (or (in x u-long) (in y u-long))
            (return (integer-to-u-long r))
            (return (integer-to-long r)))))
      (return (float64-remainder (to-float64 x) (to-float64 y))))
    
    
    (%heading 2 "Additive Operators")
    (rule :additive-expression ((validate (-> (context environment) void)) (setup (-> () void))
                                (eval (-> (environment phase) obj-or-ref)))
      (production :additive-expression (:multiplicative-expression) additive-expression-multiplicative
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase) (return ((eval :multiplicative-expression) env phase))))
      (production :additive-expression (:additive-expression + :multiplicative-expression) additive-expression-add
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :additive-expression) env phase) phase))
         (const b object (read-reference ((eval :multiplicative-expression) env phase) phase))
         (return (add a b phase))))
      (production :additive-expression (:additive-expression - :multiplicative-expression) additive-expression-subtract
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :additive-expression) env phase) phase))
         (const b object (read-reference ((eval :multiplicative-expression) env phase) phase))
         (return (subtract a b phase)))))
    (%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
    
    (define (add (a object) (b object) (phase phase)) object
      (const ap primitive-object (object-to-primitive a none phase))
      (const bp primitive-object (object-to-primitive b none phase))
      (rwhen (or (in ap (union char16 string)) (in bp (union char16 string)))
        (return (append (object-to-string ap phase) (object-to-string bp phase))))
      (const x general-number (object-to-general-number ap phase))
      (const y general-number (object-to-general-number bp phase))
      (when (or (in x (union long u-long)) (in y (union long u-long)))
        (const i integer-opt (check-integer x))
        (const j integer-opt (check-integer y))
        (rwhen (and (not-in i (tag none) :narrow-true) (not-in j (tag none) :narrow-true))
          (const k integer (+ i j))
          (if (or (in x u-long) (in y u-long))
            (return (integer-to-u-long k))
            (return (integer-to-long k)))))
      (return (float64-add (to-float64 x) (to-float64 y))))
    
    (define (subtract (a object) (b object) (phase phase)) object
      (const x general-number (object-to-general-number a phase))
      (const y general-number (object-to-general-number b phase))
      (when (or (in x (union long u-long)) (in y (union long u-long)))
        (const i integer-opt (check-integer x))
        (const j integer-opt (check-integer y))
        (rwhen (and (not-in i (tag none) :narrow-true) (not-in j (tag none) :narrow-true))
          (const k integer (- i j))
          (if (or (in x u-long) (in y u-long))
            (return (integer-to-u-long k))
            (return (integer-to-long k)))))
      (return (float64-subtract (to-float64 x) (to-float64 y))))
    
    
    (%heading 2 "Bitwise Shift Operators")
    (rule :shift-expression ((validate (-> (context environment) void)) (setup (-> () void))
                             (eval (-> (environment phase) obj-or-ref)))
      (production :shift-expression (:additive-expression) shift-expression-additive
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase) (return ((eval :additive-expression) env phase))))
      (production :shift-expression (:shift-expression << :additive-expression) shift-expression-left
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :shift-expression) env phase) phase))
         (const b object (read-reference ((eval :additive-expression) env phase) phase))
         (return (shift-left a b phase))))
      (production :shift-expression (:shift-expression >> :additive-expression) shift-expression-right-signed
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :shift-expression) env phase) phase))
         (const b object (read-reference ((eval :additive-expression) env phase) phase))
         (return (shift-right a b phase))))
      (production :shift-expression (:shift-expression >>> :additive-expression) shift-expression-right-unsigned
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :shift-expression) env phase) phase))
         (const b object (read-reference ((eval :additive-expression) env phase) phase))
         (return (shift-right-unsigned a b phase)))))
    (%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
    
    (define (shift-left (a object) (b object) (phase phase)) object
      (const x general-number (object-to-general-number a phase))
      (var count integer (truncate-to-integer (object-to-general-number b phase)))
      (case x
        (:narrow (union float32 float64)
          (<- count (bitwise-and count (hex #x1F)))
          (const i (integer-range (neg (expt 2 31)) (- (expt 2 31) 1)) (signed-wrap32 (bitwise-shift (truncate-to-integer x) count)))
          (return (real-to-float64 i)))
        (:narrow long
          (<- count (bitwise-and count (hex #x3F)))
          (const i (integer-range (neg (expt 2 63)) (- (expt 2 63) 1)) (signed-wrap64 (bitwise-shift (& value x) count)))
          (return (new long i)))
        (:narrow u-long
          (<- count (bitwise-and count (hex #x3F)))
          (const i (integer-range 0 (- (expt 2 64) 1)) (unsigned-wrap64 (bitwise-shift (& value x) count)))
          (return (new u-long i)))))
    
    (define (shift-right (a object) (b object) (phase phase)) object
      (const x general-number (object-to-general-number a phase))
      (var count integer (truncate-to-integer (object-to-general-number b phase)))
      (case x
        (:narrow (union float32 float64)
          (var i (integer-range (neg (expt 2 31)) (- (expt 2 31) 1)) (signed-wrap32 (truncate-to-integer x)))
          (<- count (bitwise-and count (hex #x1F)))
          (<- i (bitwise-shift i (neg count)))
          (return (real-to-float64 i)))
        (:narrow long
          (<- count (bitwise-and count (hex #x3F)))
          (const i (integer-range (neg (expt 2 63)) (- (expt 2 63) 1)) (bitwise-shift (& value x) (neg count)))
          (return (new long i)))
        (:narrow u-long
          (<- count (bitwise-and count (hex #x3F)))
          (const i (integer-range (neg (expt 2 63)) (- (expt 2 63) 1)) (bitwise-shift (signed-wrap64 (& value x)) (neg count)))
          (return (new u-long (unsigned-wrap64 i))))))
    
    (define (shift-right-unsigned (a object) (b object) (phase phase)) object
      (const x general-number (object-to-general-number a phase))
      (var count integer (truncate-to-integer (object-to-general-number b phase)))
      (case x
        (:narrow (union float32 float64)
          (var i (integer-range 0 (- (expt 2 32) 1)) (unsigned-wrap32 (truncate-to-integer x)))
          (<- count (bitwise-and count (hex #x1F)))
          (<- i (bitwise-shift i (neg count)))
          (return (real-to-float64 i)))
        (:narrow long
          (<- count (bitwise-and count (hex #x3F)))
          (const i (integer-range 0 (- (expt 2 64) 1)) (bitwise-shift (unsigned-wrap64 (& value x)) (neg count)))
          (return (new long (signed-wrap64 i))))
        (:narrow u-long
          (<- count (bitwise-and count (hex #x3F)))
          (const i (integer-range 0 (- (expt 2 64) 1)) (bitwise-shift (& value x) (neg count)))
          (return (new u-long i)))))
    
    
    (%heading 2 "Relational Operators")
    (rule (:relational-expression :beta) ((validate (-> (context environment) void)) (setup (-> () void))
                                          (eval (-> (environment phase) obj-or-ref)))
      (production (:relational-expression :beta) (:shift-expression) relational-expression-shift
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase) (return ((eval :shift-expression) env phase))))
      (production (:relational-expression :beta) ((:relational-expression :beta) < :shift-expression) relational-expression-less
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :relational-expression) env phase) phase))
         (const b object (read-reference ((eval :shift-expression) env phase) phase))
         (return (is-less a b phase))))
      (production (:relational-expression :beta) ((:relational-expression :beta) > :shift-expression) relational-expression-greater
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :relational-expression) env phase) phase))
         (const b object (read-reference ((eval :shift-expression) env phase) phase))
         (return (is-less b a phase))))
      (production (:relational-expression :beta) ((:relational-expression :beta) <= :shift-expression) relational-expression-less-or-equal
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :relational-expression) env phase) phase))
         (const b object (read-reference ((eval :shift-expression) env phase) phase))
         (return (is-less-or-equal a b phase))))
      (production (:relational-expression :beta) ((:relational-expression :beta) >= :shift-expression) relational-expression-greater-or-equal
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :relational-expression) env phase) phase))
         (const b object (read-reference ((eval :shift-expression) env phase) phase))
         (return (is-less-or-equal b a phase))))
      (production (:relational-expression :beta) ((:relational-expression :beta) is :shift-expression) relational-expression-is
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :relational-expression) env phase) phase))
         (const b object (read-reference ((eval :shift-expression) env phase) phase))
         (const c class (object-to-class b))
         (return (is a c))))
      (production (:relational-expression :beta) ((:relational-expression :beta) as :shift-expression) relational-expression-as
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :relational-expression) env phase) phase))
         (const b object (read-reference ((eval :shift-expression) env phase) phase))
         (const c class (object-to-class b))
         (return (coerce-or-null a c))))
      (production (:relational-expression allow-in) ((:relational-expression allow-in) in :shift-expression) relational-expression-in
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :relational-expression) env phase) phase))
         (const b object (read-reference ((eval :shift-expression) env phase) phase))
         (return (has-property b a false phase))))
      (production (:relational-expression :beta) ((:relational-expression :beta) instanceof :shift-expression) relational-expression-instanceof
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (var a object (read-reference ((eval :relational-expression) env phase) phase))
         (const b object (read-reference ((eval :shift-expression) env phase) phase))
         (cond
          ((in b class :narrow-true)
           (return (is a b)))
          ((is b -prototype-function)
           (const prototype object (dot-read b (list-set (new qualified-name public "prototype")) phase))
           (return (set-in prototype (archetypes a))))
          (nil 
           (throw-error -type-error))))))
    (%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
    
    (define (is-less (a object) (b object) (phase phase)) boolean
      (const ap primitive-object (object-to-primitive a hint-number phase))
      (const bp primitive-object (object-to-primitive b hint-number phase))
      (rwhen (and (in ap (union char16 string) :narrow-true) (in bp (union char16 string) :narrow-true))
        (return (< (to-string ap) (to-string bp) string)))
      (return (= (general-number-compare (object-to-general-number ap phase) (object-to-general-number bp phase)) less order)))
    
    (define (is-less-or-equal (a object) (b object) (phase phase)) boolean
      (const ap primitive-object (object-to-primitive a hint-number phase))
      (const bp primitive-object (object-to-primitive b hint-number phase))
      (rwhen (and (in ap (union char16 string) :narrow-true) (in bp (union char16 string) :narrow-true))
        (return (<= (to-string ap) (to-string bp) string)))
      (return (in (general-number-compare (object-to-general-number ap phase) (object-to-general-number bp phase)) (tag less equal))))
    
    
    (%heading 2 "Equality Operators")
    (rule (:equality-expression :beta) ((validate (-> (context environment) void)) (setup (-> () void))
                                        (eval (-> (environment phase) obj-or-ref)))
      (production (:equality-expression :beta) ((:relational-expression :beta)) equality-expression-relational
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase) (return ((eval :relational-expression) env phase))))
      (production (:equality-expression :beta) ((:equality-expression :beta) == (:relational-expression :beta)) equality-expression-equal
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :equality-expression) env phase) phase))
         (const b object (read-reference ((eval :relational-expression) env phase) phase))
         (return (is-equal a b phase))))
      (production (:equality-expression :beta) ((:equality-expression :beta) != (:relational-expression :beta)) equality-expression-not-equal
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :equality-expression) env phase) phase))
         (const b object (read-reference ((eval :relational-expression) env phase) phase))
         (return (not (is-equal a b phase)))))
      (production (:equality-expression :beta) ((:equality-expression :beta) === (:relational-expression :beta)) equality-expression-strict-equal
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :equality-expression) env phase) phase))
         (const b object (read-reference ((eval :relational-expression) env phase) phase))
         (return (is-strictly-equal a b phase))))
      (production (:equality-expression :beta) ((:equality-expression :beta) !== (:relational-expression :beta)) equality-expression-strict-not-equal
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :equality-expression) env phase) phase))
         (const b object (read-reference ((eval :relational-expression) env phase) phase))
         (return (not (is-strictly-equal a b phase))))))
    (%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
    
    (define (is-equal (a object) (b object) (phase phase)) boolean
      (case a
        (:select (union undefined null)
          (return (in b (union undefined null))))
        (:narrow boolean
          (if (in b boolean :narrow-true)
            (return (= a b boolean))
            (return (is-equal (object-to-general-number a phase) b phase))))
        (:narrow general-number
          (const bp primitive-object (object-to-primitive b none phase))
          (case bp
            (:select (union undefined null) (return false))
            (:select (union boolean general-number char16 string) (return (= (general-number-compare a (object-to-general-number bp phase)) equal order)))))
        (:narrow (union char16 string)
          (const bp primitive-object (object-to-primitive b none phase))
          (case bp
            (:select (union undefined null) (return false))
            (:select (union boolean general-number) (return (= (general-number-compare (object-to-general-number a phase) (object-to-general-number bp phase)) equal order)))
            (:narrow (union char16 string) (return (= (to-string a) (to-string bp) string)))))
        (:select (union namespace compound-attribute class method-closure simple-instance date reg-exp package)
          (case b
            (:select (union undefined null) (return false))
            (:select (union namespace compound-attribute class method-closure simple-instance date reg-exp package) (return (is-strictly-equal a b phase)))
            (:select (union boolean general-number char16 string)
              (const ap primitive-object (object-to-primitive a none phase))
              (return (is-equal ap b phase)))))))
    
    (define (is-strictly-equal (a object) (b object) (phase phase :unused)) boolean
      (cond
       ((and (in a general-number :narrow-true) (in b general-number :narrow-true))
        (return (= (general-number-compare a b) equal order)))
       (nil
        (return (= a b object)))))
    
    
    (%heading 2 "Binary Bitwise Operators")
    (rule (:bitwise-and-expression :beta) ((validate (-> (context environment) void)) (setup (-> () void))
                                           (eval (-> (environment phase) obj-or-ref)))
      (production (:bitwise-and-expression :beta) ((:equality-expression :beta)) bitwise-and-expression-equality
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase) (return ((eval :equality-expression) env phase))))
      (production (:bitwise-and-expression :beta) ((:bitwise-and-expression :beta) & (:equality-expression :beta)) bitwise-and-expression-and
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :bitwise-and-expression) env phase) phase))
         (const b object (read-reference ((eval :equality-expression) env phase) phase))
         (return (bit-and a b phase)))))
    
    (rule (:bitwise-xor-expression :beta) ((validate (-> (context environment) void)) (setup (-> () void))
                                           (eval (-> (environment phase) obj-or-ref)))
      (production (:bitwise-xor-expression :beta) ((:bitwise-and-expression :beta)) bitwise-xor-expression-bitwise-and
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase) (return ((eval :bitwise-and-expression) env phase))))
      (production (:bitwise-xor-expression :beta) ((:bitwise-xor-expression :beta) ^ (:bitwise-and-expression :beta)) bitwise-xor-expression-xor
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :bitwise-xor-expression) env phase) phase))
         (const b object (read-reference ((eval :bitwise-and-expression) env phase) phase))
         (return (bit-xor a b phase)))))
    
    (rule (:bitwise-or-expression :beta) ((validate (-> (context environment) void)) (setup (-> () void))
                                          (eval (-> (environment phase) obj-or-ref)))
      (production (:bitwise-or-expression :beta) ((:bitwise-xor-expression :beta)) bitwise-or-expression-bitwise-xor
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase) (return ((eval :bitwise-xor-expression) env phase))))
      (production (:bitwise-or-expression :beta) ((:bitwise-or-expression :beta) \| (:bitwise-xor-expression :beta)) bitwise-or-expression-or
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :bitwise-or-expression) env phase) phase))
         (const b object (read-reference ((eval :bitwise-xor-expression) env phase) phase))
         (return (bit-or a b phase)))))
    (%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
    
    (define (bit-and (a object) (b object) (phase phase)) general-number
      (const x general-number (object-to-general-number a phase))
      (const y general-number (object-to-general-number b phase))
      (cond
       ((or (in x (union long u-long) :narrow-false) (in y (union long u-long) :narrow-false))
        (const i (integer-range (neg (expt 2 63)) (- (expt 2 63) 1)) (signed-wrap64 (truncate-to-integer x)))
        (const j (integer-range (neg (expt 2 63)) (- (expt 2 63) 1)) (signed-wrap64 (truncate-to-integer y)))
        (const k (integer-range (neg (expt 2 63)) (- (expt 2 63) 1)) (bitwise-and i j))
        (if (or (in x u-long) (in y u-long))
          (return (new u-long (unsigned-wrap64 k)))
          (return (new long k))))
       (nil
        (const i (integer-range (neg (expt 2 31)) (- (expt 2 31) 1)) (signed-wrap32 (truncate-to-integer x)))
        (const j (integer-range (neg (expt 2 31)) (- (expt 2 31) 1)) (signed-wrap32 (truncate-to-integer y)))
        (return (real-to-float64 (bitwise-and i j))))))
    
    (define (bit-xor (a object) (b object) (phase phase)) general-number
      (const x general-number (object-to-general-number a phase))
      (const y general-number (object-to-general-number b phase))
      (cond
       ((or (in x (union long u-long) :narrow-false) (in y (union long u-long) :narrow-false))
        (const i (integer-range (neg (expt 2 63)) (- (expt 2 63) 1)) (signed-wrap64 (truncate-to-integer x)))
        (const j (integer-range (neg (expt 2 63)) (- (expt 2 63) 1)) (signed-wrap64 (truncate-to-integer y)))
        (const k (integer-range (neg (expt 2 63)) (- (expt 2 63) 1)) (bitwise-xor i j))
        (if (or (in x u-long) (in y u-long))
          (return (new u-long (unsigned-wrap64 k)))
          (return (new long k))))
       (nil
        (const i (integer-range (neg (expt 2 31)) (- (expt 2 31) 1)) (signed-wrap32 (truncate-to-integer x)))
        (const j (integer-range (neg (expt 2 31)) (- (expt 2 31) 1)) (signed-wrap32 (truncate-to-integer y)))
        (return (real-to-float64 (bitwise-xor i j))))))
    
    (define (bit-or (a object) (b object) (phase phase)) general-number
      (const x general-number (object-to-general-number a phase))
      (const y general-number (object-to-general-number b phase))
      (cond
       ((or (in x (union long u-long) :narrow-false) (in y (union long u-long) :narrow-false))
        (const i (integer-range (neg (expt 2 63)) (- (expt 2 63) 1)) (signed-wrap64 (truncate-to-integer x)))
        (const j (integer-range (neg (expt 2 63)) (- (expt 2 63) 1)) (signed-wrap64 (truncate-to-integer y)))
        (const k (integer-range (neg (expt 2 63)) (- (expt 2 63) 1)) (bitwise-or i j))
        (if (or (in x u-long) (in y u-long))
          (return (new u-long (unsigned-wrap64 k)))
          (return (new long k))))
       (nil
        (const i (integer-range (neg (expt 2 31)) (- (expt 2 31) 1)) (signed-wrap32 (truncate-to-integer x)))
        (const j (integer-range (neg (expt 2 31)) (- (expt 2 31) 1)) (signed-wrap32 (truncate-to-integer y)))
        (return (real-to-float64 (bitwise-or i j))))))
    
    
    (%heading 2 "Binary Logical Operators")
    (rule (:logical-and-expression :beta) ((validate (-> (context environment) void)) (setup (-> () void))
                                           (eval (-> (environment phase) obj-or-ref)))
      (production (:logical-and-expression :beta) ((:bitwise-or-expression :beta)) logical-and-expression-bitwise-or
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase) (return ((eval :bitwise-or-expression) env phase))))
      (production (:logical-and-expression :beta) ((:logical-and-expression :beta) && (:bitwise-or-expression :beta)) logical-and-expression-and
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :logical-and-expression) env phase) phase))
         (if (object-to-boolean a)
           (return (read-reference ((eval :bitwise-or-expression) env phase) phase))
           (return a)))))
    
    (rule (:logical-xor-expression :beta) ((validate (-> (context environment) void)) (setup (-> () void))
                                           (eval (-> (environment phase) obj-or-ref)))
      (production (:logical-xor-expression :beta) ((:logical-and-expression :beta)) logical-xor-expression-logical-and
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase) (return ((eval :logical-and-expression) env phase))))
      (production (:logical-xor-expression :beta) ((:logical-xor-expression :beta) ^^ (:logical-and-expression :beta)) logical-xor-expression-xor
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :logical-xor-expression) env phase) phase))
         (const b object (read-reference ((eval :logical-and-expression) env phase) phase))
         (const ba boolean (object-to-boolean a))
         (const bb boolean (object-to-boolean b))
         (return (xor ba bb)))))
    
    (rule (:logical-or-expression :beta) ((validate (-> (context environment) void)) (setup (-> () void))
                                          (eval (-> (environment phase) obj-or-ref)))
      (production (:logical-or-expression :beta) ((:logical-xor-expression :beta)) logical-or-expression-logical-xor
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase) (return ((eval :logical-xor-expression) env phase))))
      (production (:logical-or-expression :beta) ((:logical-or-expression :beta) \|\| (:logical-xor-expression :beta)) logical-or-expression-or
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :logical-or-expression) env phase) phase))
         (if (object-to-boolean a)
           (return a)
           (return (read-reference ((eval :logical-xor-expression) env phase) phase))))))
    (%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
    
    
    (%heading 2 "Conditional Operator")
    (rule (:conditional-expression :beta) ((validate (-> (context environment) void)) (setup (-> () void))
                                           (eval (-> (environment phase) obj-or-ref)))
      (production (:conditional-expression :beta) ((:logical-or-expression :beta)) conditional-expression-logical-or
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase) (return ((eval :logical-or-expression) env phase))))
      (production (:conditional-expression :beta) ((:logical-or-expression :beta) ? (:assignment-expression :beta) \: (:assignment-expression :beta)) conditional-expression-conditional
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :logical-or-expression) env phase) phase))
         (if (object-to-boolean a)
           (return (read-reference ((eval :assignment-expression 1) env phase) phase))
           (return (read-reference ((eval :assignment-expression 2) env phase) phase))))))
    
    (rule (:non-assignment-expression :beta) ((validate (-> (context environment) void)) (setup (-> () void))
                                              (eval (-> (environment phase) obj-or-ref)))
      (production (:non-assignment-expression :beta) ((:logical-or-expression :beta)) non-assignment-expression-logical-or
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase) (return ((eval :logical-or-expression) env phase))))
      (production (:non-assignment-expression :beta) ((:logical-or-expression :beta) ? (:non-assignment-expression :beta) \: (:non-assignment-expression :beta)) non-assignment-expression-conditional
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :logical-or-expression) env phase) phase))
         (if (object-to-boolean a)
           (return (read-reference ((eval :non-assignment-expression 1) env phase) phase))
           (return (read-reference ((eval :non-assignment-expression 2) env phase) phase))))))
    (%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
    
    
    (%heading 2 "Assignment Operators")
    (rule (:assignment-expression :beta) ((validate (-> (context environment) void)) (setup (-> () void))
                                          (eval (-> (environment phase) obj-or-ref)))
      (production (:assignment-expression :beta) ((:conditional-expression :beta)) assignment-expression-conditional
        ((validate cxt env) ((validate :conditional-expression) cxt env))
        ((setup) ((setup :conditional-expression)))
        ((eval env phase) (return ((eval :conditional-expression) env phase))))
      (production (:assignment-expression :beta) (:postfix-expression = (:assignment-expression :beta)) assignment-expression-assignment
        ((validate cxt env)
         ((validate :postfix-expression) cxt env)
         ((validate :assignment-expression) cxt env))
        ((setup)
         ((setup :postfix-expression))
         ((setup :assignment-expression)))
        ((eval env phase)
         (rwhen (in phase (tag compile) :narrow-false)
           (throw-error -constant-error "assignment cannot be used in a constant expression"))
         (const ra obj-or-ref ((eval :postfix-expression) env phase))
         (const b object (read-reference ((eval :assignment-expression) env phase) phase))
         (write-reference ra b phase)
         (return b)))
      (production (:assignment-expression :beta) (:postfix-expression :compound-assignment (:assignment-expression :beta)) assignment-expression-compound
        ((validate cxt env)
         ((validate :postfix-expression) cxt env)
         ((validate :assignment-expression) cxt env))
        ((setup)
         ((setup :postfix-expression))
         ((setup :assignment-expression)))
        ((eval env phase)
         (rwhen (in phase (tag compile) :narrow-false)
           (throw-error -constant-error "assignment cannot be used in a constant expression"))
         (const r-left obj-or-ref ((eval :postfix-expression) env phase))
         (const o-left object (read-reference r-left phase))
         (const o-right object (read-reference ((eval :assignment-expression) env phase) phase))
         (const result object ((op :compound-assignment) o-left o-right phase))
         (write-reference r-left result phase)
         (return result)))
      (production (:assignment-expression :beta) (:postfix-expression :logical-assignment (:assignment-expression :beta)) assignment-expression-logical-compound
        ((validate cxt env)
         ((validate :postfix-expression) cxt env)
         ((validate :assignment-expression) cxt env))
        ((setup)
         ((setup :postfix-expression))
         ((setup :assignment-expression)))
        ((eval env phase)
         (rwhen (in phase (tag compile) :narrow-false)
           (throw-error -constant-error "assignment cannot be used in a constant expression"))
         (const r-left obj-or-ref ((eval :postfix-expression) env phase))
         (const o-left object (read-reference r-left phase))
         (const b-left boolean (object-to-boolean o-left))
         (var result object o-left)
         (case (operator :logical-assignment)
           (:select (tag and-eq)
             (when b-left
               (<- result (read-reference ((eval :assignment-expression) env phase) phase))))
           (:select (tag xor-eq)
             (const b-right boolean (object-to-boolean (read-reference ((eval :assignment-expression) env phase) phase)))
             (<- result (xor b-left b-right)))
           (:select (tag or-eq)
             (when (not b-left)
               (<- result (read-reference ((eval :assignment-expression) env phase) phase)))))
         (write-reference r-left result phase)
         (return result))))
    
    (rule :compound-assignment ((op (-> (object object phase) object)))
      (production :compound-assignment (*=) compound-assignment-multiply (op multiply))
      (production :compound-assignment (/=) compound-assignment-divide (op divide))
      (production :compound-assignment (%=) compound-assignment-remainder (op remainder))
      (production :compound-assignment (+=) compound-assignment-add (op add))
      (production :compound-assignment (-=) compound-assignment-subtract (op subtract))
      (production :compound-assignment (<<=) compound-assignment-shift-left (op shift-left))
      (production :compound-assignment (>>=) compound-assignment-shift-right (op shift-right))
      (production :compound-assignment (>>>=) compound-assignment-shift-right-unsigned (op shift-right-unsigned))
      (production :compound-assignment (&=) compound-assignment-bit-and (op bit-and))
      (production :compound-assignment (^=) compound-assignment-bit-xor (op bit-xor))
      (production :compound-assignment (\|=) compound-assignment-bit-or (op bit-or)))
    
    (rule :logical-assignment ((operator (tag and-eq xor-eq or-eq)))
      (production :logical-assignment (&&=) logical-assignment-logical-and (operator and-eq))
      (production :logical-assignment (^^=) logical-assignment-logical-xor (operator xor-eq))
      (production :logical-assignment (\|\|=) logical-assignment-logical-or (operator or-eq)))
    
    (deftag and-eq)
    (deftag xor-eq)
    (deftag or-eq)
    (%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" op operator eval))
    
    
    (%heading 2 "Comma Expressions")
    (rule (:list-expression :beta) ((validate (-> (context environment) void)) (setup (-> () void))
                                    (eval (-> (environment phase) obj-or-ref))
                                    (eval-as-list (-> (environment phase) (vector object))))
      (production (:list-expression :beta) ((:assignment-expression :beta)) list-expression-assignment
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase) (return ((eval :assignment-expression) env phase)))
        ((eval-as-list env phase)
         (const elt object (read-reference ((eval :assignment-expression) env phase) phase))
         (return (vector elt))))
      (production (:list-expression :beta) ((:list-expression :beta) \, (:assignment-expression :beta)) list-expression-comma
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (exec (read-reference ((eval :list-expression) env phase) phase))
         (return (read-reference ((eval :assignment-expression) env phase) phase)))
        ((eval-as-list env phase)
         (const elts (vector object) ((eval-as-list :list-expression) env phase))
         (const elt object (read-reference ((eval :assignment-expression) env phase) phase))
         (return (append elts (vector elt))))))
    (%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
    
    
    (%heading 2 "Type Expressions")
    (rule (:type-expression :beta) ((validate (-> (context environment) void))
                                    (setup-and-eval (-> (environment) class)))
      (production (:type-expression :beta) ((:non-assignment-expression :beta)) type-expression-non-assignment-expression
        ((validate cxt env) :forward)
        ((setup-and-eval env)
         ((setup :non-assignment-expression))
         (const o object (read-reference ((eval :non-assignment-expression) env compile) compile))
         (return (object-to-class o)))))
    (%print-actions ("Validation" validate) ("Setup and Evaluation" setup-and-eval))
    
    
    (%heading 1 "Statements")
    
    (grammar-argument :omega
                      abbrev       ;optional semicolon when followed by a '}', 'else', or 'while' in a do-while
                      no-short-if  ;optional semicolon, but statement must not end with an if without an else
                      full)        ;semicolon required at the end
    (grammar-argument :omega_2 abbrev full)
    
    (rule (:statement :omega) ((validate (-> (context environment (list-set label) jump-targets boolean) void)) (setup (-> () void))
                               (eval (-> (environment object) object)))
      (production (:statement :omega) (:expression-statement (:semicolon :omega)) statement-expression-statement
        ((validate cxt env (sl :unused) (jt :unused) (preinst :unused)) ((validate :expression-statement) cxt env))
        ((setup) :forward)
        ((eval env (d :unused)) (return ((eval :expression-statement) env))))
      (production (:statement :omega) (:super-statement (:semicolon :omega)) statement-super-statement
        ((validate cxt env (sl :unused) (jt :unused) (preinst :unused)) ((validate :super-statement) cxt env))
        ((setup) :forward)
        ((eval env (d :unused)) (return ((eval :super-statement) env))))
      (production (:statement :omega) (:block) statement-block
        ((validate cxt env (sl :unused) jt preinst) ((validate :block) cxt env jt preinst))
        ((setup) :forward)
        ((eval env d) (return ((eval :block) env d))))
      (production (:statement :omega) ((:labeled-statement :omega)) statement-labeled-statement
        ((validate cxt env sl jt (preinst :unused)) ((validate :labeled-statement) cxt env sl jt))
        ((setup) :forward)
        ((eval env d) (return ((eval :labeled-statement) env d))))
      (production (:statement :omega) ((:if-statement :omega)) statement-if-statement
        ((validate cxt env (sl :unused) jt (preinst :unused)) ((validate :if-statement) cxt env jt))
        ((setup) :forward)
        ((eval env d) (return ((eval :if-statement) env d))))
      (production (:statement :omega) (:switch-statement) statement-switch-statement
        ((validate cxt env (sl :unused) jt (preinst :unused)) ((validate :switch-statement) cxt env jt))
        ((setup) :forward)
        ((eval env d) (return ((eval :switch-statement) env d))))
      (production (:statement :omega) (:do-statement (:semicolon :omega)) statement-do-statement
        ((validate cxt env sl jt (preinst :unused)) ((validate :do-statement) cxt env sl jt))
        ((setup) :forward)
        ((eval env d) (return ((eval :do-statement) env d))))
      (production (:statement :omega) ((:while-statement :omega)) statement-while-statement
        ((validate cxt env sl jt (preinst :unused)) ((validate :while-statement) cxt env sl jt))
        ((setup) :forward)
        ((eval env d) (return ((eval :while-statement) env d))))
      (production (:statement :omega) ((:for-statement :omega)) statement-for-statement
        ((validate cxt env sl jt (preinst :unused)) ((validate :for-statement) cxt env sl jt))
        ((setup) :forward)
        ((eval env d) (return ((eval :for-statement) env d))))
      (production (:statement :omega) ((:with-statement :omega)) statement-with-statement
        ((validate cxt env (sl :unused) jt (preinst :unused)) ((validate :with-statement) cxt env jt))
        ((setup) :forward)
        ((eval env d) (return ((eval :with-statement) env d))))
      (production (:statement :omega) (:continue-statement (:semicolon :omega)) statement-continue-statement
        ((validate (cxt :unused) (env :unused) (sl :unused) jt (preinst :unused)) ((validate :continue-statement) jt))
        ((setup) :forward)
        ((eval env d) (return ((eval :continue-statement) env d))))
      (production (:statement :omega) (:break-statement (:semicolon :omega)) statement-break-statement
        ((validate (cxt :unused) (env :unused) (sl :unused) jt (preinst :unused)) ((validate :break-statement) jt))
        ((setup) :forward)
        ((eval env d) (return ((eval :break-statement) env d))))
      (production (:statement :omega) (:return-statement (:semicolon :omega)) statement-return-statement
        ((validate cxt env (sl :unused) (jt :unused) (preinst :unused)) ((validate :return-statement) cxt env))
        ((setup) :forward)
        ((eval env (d :unused)) (return ((eval :return-statement) env))))
      (production (:statement :omega) (:throw-statement (:semicolon :omega)) statement-throw-statement
        ((validate cxt env (sl :unused) (jt :unused) (preinst :unused)) ((validate :throw-statement) cxt env))
        ((setup) :forward)
        ((eval env (d :unused)) (return ((eval :throw-statement) env))))
      (production (:statement :omega) (:try-statement) statement-try-statement
        ((validate cxt env (sl :unused) jt (preinst :unused)) ((validate :try-statement) cxt env jt))
        ((setup) :forward)
        ((eval env d) (return ((eval :try-statement) env d)))))
    
    
    (rule (:substatement :omega) ((enabled (writable-cell boolean))
                                  (validate (-> (context environment (list-set label) jump-targets) void))
                                  (setup (-> () void))
                                  (eval (-> (environment object) object)))
      (production (:substatement :omega) (:empty-statement) substatement-empty-statement
        ((validate (cxt :unused) (env :unused) (sl :unused) (jt :unused)))
        ((setup))
        ((eval (env :unused) d) (return d)))
      (production (:substatement :omega) ((:statement :omega)) substatement-statement
        ((validate cxt env sl jt) ((validate :statement) cxt env sl jt false))
        ((setup) ((setup :statement)))
        ((eval env d) (return ((eval :statement) env d))))
      (production (:substatement :omega) (:simple-variable-definition (:semicolon :omega)) substatement-simple-variable-definition
        ((validate cxt env (sl :unused) (jt :unused)) ((validate :simple-variable-definition) cxt env))
        ((setup) ((setup :simple-variable-definition)))
        ((eval env d) (return ((eval :simple-variable-definition) env d))))
      (production (:substatement :omega) (:attributes :no-line-break { :substatements }) substatement-annotated-group
        ((validate cxt env (sl :unused) jt)
         ((validate :attributes) cxt env)
         ((setup :attributes))
         (const attr attribute ((eval :attributes) env compile))
         (rwhen (not-in attr boolean :narrow-false)
           (throw-error -type-error
             "attributes other than " (:character-literal "true") " and " (:character-literal "false")
             " may be used in a statement but not a substatement"))
         (action<- (enabled :substatement 0) attr)
         (when attr
           ((validate :substatements) cxt env jt)))
        ((setup)
         (when (enabled :substatement 0)
           ((setup :substatements))))
        ((eval env d)
         (if (enabled :substatement 0)
           (return ((eval :substatements) env d))
           (return d)))))
    
    
    (rule :substatements ((validate (-> (context environment jump-targets) void)) (setup (-> () void))
                          (eval (-> (environment object) object)))
      (production :substatements () substatements-none
        ((validate (cxt :unused) (env :unused) (jt :unused)))
        ((setup) :forward)
        ((eval (env :unused) d) (return d)))
      (production :substatements (:substatements-prefix (:substatement abbrev)) substatements-more
        ((validate cxt env jt)
         ((validate :substatements-prefix) cxt env jt)
         ((validate :substatement) cxt env (list-set-of label) jt))
        ((setup) :forward)
        ((eval env d)
         (const o object ((eval :substatements-prefix) env d))
         (return ((eval :substatement) env o)))))
    
    (rule :substatements-prefix ((validate (-> (context environment jump-targets) void)) (setup (-> () void))
                                 (eval (-> (environment object) object)))
      (production :substatements-prefix () substatements-prefix-none
        ((validate (cxt :unused) (env :unused) (jt :unused)))
        ((setup) :forward)
        ((eval (env :unused) d) (return d)))
      (production :substatements-prefix (:substatements-prefix (:substatement full)) substatements-prefix-more
        ((validate cxt env jt)
         ((validate :substatements-prefix) cxt env jt)
         ((validate :substatement) cxt env (list-set-of label) jt))
        ((setup) :forward)
        ((eval env d)
         (const o object ((eval :substatements-prefix) env d))
         (return ((eval :substatement) env o)))))
    
    
    (rule (:semicolon :omega) ((setup (-> () void)))
      (production (:semicolon :omega) (\;) semicolon-semicolon
        ((setup)))
      (production (:semicolon :omega) ($virtual-semicolon) semicolon-virtual-semicolon
        ((setup)))
      (production (:semicolon abbrev) () semicolon-abbrev
        ((setup)))
      (production (:semicolon no-short-if) () semicolon-no-short-if
        ((setup))))
    (%print-actions ("Validation" enabled validate) ("Setup" setup) ("Evaluation" eval))
    
    
    (%heading 2 "Empty Statement")
    (production :empty-statement (\;) empty-statement-semicolon)
    
    
    (%heading 2 "Expression Statement")
    (rule :expression-statement ((validate (-> (context environment) void)) (setup (-> () void))
                                 (eval (-> (environment) object)))
      (production :expression-statement ((:- function {) (:list-expression allow-in)) expression-statement-list-expression
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env)
         (return (read-reference ((eval :list-expression) env run) run)))))
    (%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
    
    
    (%heading 2 "Super Statement")
    (rule :super-statement ((validate (-> (context environment) void)) (setup (-> () void))
                            (eval (-> (environment) object)))
      (production :super-statement (super :arguments) super-statement-super-arguments
        ((validate cxt env)
         (const frame parameter-frame-opt (get-enclosing-parameter-frame env))
         (rwhen (or (in frame (tag none) :narrow-false) (not-in (& kind frame) (tag constructor-function)))
           (throw-error -syntax-error "a " (:character-literal "super") " statement is meaningful only inside a constructor"))
         ((validate :arguments) cxt env)
         (&= calls-superconstructor frame true))
        ((setup) :forward)
        ((eval env)
         (const frame parameter-frame-opt (get-enclosing-parameter-frame env))
         (assert (and (not-in frame (tag none) :narrow-true) (in (& kind frame) (tag constructor-function)))
           (:action validate) " already ensured that " (:assertion) ".")
         (const args (vector object) ((eval :arguments) env run))
         (rwhen (in (& superconstructor-called frame) (tag true))
           (throw-error -reference-error "the superconstructor cannot be called twice"))
         (const c class (assert-not-in (get-enclosing-class env) (tag none)))
         (const this object-opt (& this frame))
         (assert (in this simple-instance :narrow-true))
         (call-init this (& super c) args run)
         (&= superconstructor-called frame true)
         (return this))))
    (%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
    
    
    (%heading 2 "Block Statement")
    (rule :block ((compile-frame (writable-cell local-frame))
                  (preinstantiate (writable-cell boolean))
                  (validate-using-frame (-> (context environment jump-targets boolean frame) void))
                  (validate (-> (context environment jump-targets boolean) void))
                  (setup (-> () void))
                  (eval (-> (environment object) object))
                  (eval-using-frame (-> (environment frame object) object)))
      (production :block ({ :directives }) block-directives
        ((validate-using-frame cxt env jt preinst frame)
         (const local-cxt context (new context (& strict cxt) (& open-namespaces cxt)))
         ((validate :directives) local-cxt (cons frame env) jt preinst none))
        ((validate cxt env jt preinst)
         (const compile-frame local-frame (new local-frame (list-set-of local-binding)))
         (action<- (compile-frame :block 0) compile-frame)
         (action<- (preinstantiate :block 0) preinst)
         ((validate-using-frame :block 0) cxt env jt preinst compile-frame))
        ((setup) :forward)
        ((eval env d)
         (const compile-frame local-frame (compile-frame :block 0))
         (var runtime-frame local-frame)
         (if (preinstantiate :block 0)
           (<- runtime-frame compile-frame)
           (<- runtime-frame (instantiate-local-frame compile-frame env)))
         (return ((eval :directives) (cons runtime-frame env) d)))
        ((eval-using-frame env frame d)
         (return ((eval :directives) (cons frame env) d)))))
    (%print-actions ("Validation" compile-frame preinstantiate validate validate-using-frame) ("Setup" setup) ("Evaluation" eval eval-using-frame))
    
    
    (%heading 2 "Labeled Statements")
    (rule (:labeled-statement :omega) ((validate (-> (context environment (list-set label) jump-targets) void)) (setup (-> () void))
                                       (eval (-> (environment object) object)))
      (production (:labeled-statement :omega) (:identifier \: (:substatement :omega)) labeled-statement-label
        ((validate cxt env sl jt)
         (const name string (name :identifier))
         (rwhen (set-in name (& break-targets jt))
           (throw-error -syntax-error "nesting labeled statements with the same label is not permitted"))
         (const jt2 jump-targets (new jump-targets (set+ (& break-targets jt) (list-set-of label name)) (& continue-targets jt)))
         ((validate :substatement) cxt env (set+ sl (list-set-of label name)) jt2))
        ((setup) ((setup :substatement)))
        ((eval env d)
         (catch ((return ((eval :substatement) env d)))
           (x) (if (and (in x break :narrow-true) (= (& label x) (name :identifier) label))
                 (return (& value x))
                 (throw x))))))
    (%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
    
    
    (%heading 2 "If Statement")
    (rule (:if-statement :omega) ((validate (-> (context environment jump-targets) void)) (setup (-> () void))
                                  (eval (-> (environment object) object)))
      (production (:if-statement abbrev) (if :paren-list-expression (:substatement abbrev)) if-statement-if-then-abbrev
        ((validate cxt env jt)
         ((validate :paren-list-expression) cxt env)
         ((validate :substatement) cxt env (list-set-of label) jt))
        ((setup) :forward)
        ((eval env d)
         (const o object (read-reference ((eval :paren-list-expression) env run) run))
         (if (object-to-boolean o)
           (return ((eval :substatement) env d))
           (return d))))
      (production (:if-statement full) (if :paren-list-expression (:substatement full)) if-statement-if-then-full
        ((validate cxt env jt)
         ((validate :paren-list-expression) cxt env)
         ((validate :substatement) cxt env (list-set-of label) jt))
        ((setup) :forward)
        ((eval env d)
         (const o object (read-reference ((eval :paren-list-expression) env run) run))
         (if (object-to-boolean o)
           (return ((eval :substatement) env d))
           (return d))))
      (production (:if-statement :omega) (if :paren-list-expression (:substatement no-short-if) else (:substatement :omega))
                  if-statement-if-then-else
        ((validate cxt env jt)
         ((validate :paren-list-expression) cxt env)
         ((validate :substatement 1) cxt env (list-set-of label) jt)
         ((validate :substatement 2) cxt env (list-set-of label) jt))
        ((setup) :forward)
        ((eval env d)
         (const o object (read-reference ((eval :paren-list-expression) env run) run))
         (if (object-to-boolean o)
           (return ((eval :substatement 1) env d))
           (return ((eval :substatement 2) env d))))))
    (%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
    
    
    (%heading 2 "Switch Statement")
    (deftuple switch-key
      (key object))
    (deftype switch-guard (union switch-key (tag default) object))
    
    (rule :switch-statement ((compile-frame (writable-cell local-frame))
                             (validate (-> (context environment jump-targets) void))
                             (setup (-> () void))
                             (eval (-> (environment object) object)))
      (production :switch-statement (switch :paren-list-expression { :case-elements }) switch-statement-cases
        ((validate cxt env jt)
         (rwhen (> (n-defaults :case-elements) 1)
           (throw-error -syntax-error "a " (:character-literal "case") " statement may have at most one default clause"))
         ((validate :paren-list-expression) cxt env)
         (const jt2 jump-targets (new jump-targets
                                   (set+ (& break-targets jt) (list-set-of label default))
                                   (& continue-targets jt)))
         (const compile-frame local-frame (new local-frame (list-set-of local-binding)))
         (action<- (compile-frame :switch-statement 0) compile-frame)
         (const local-cxt context (new context (& strict cxt) (& open-namespaces cxt)))
         ((validate :case-elements) local-cxt (cons compile-frame env) jt2))
        ((setup) :forward)
        ((eval env d)
         (const key object (read-reference ((eval :paren-list-expression) env run) run))
         (const compile-frame local-frame (compile-frame :switch-statement 0))
         (const runtime-frame local-frame (instantiate-local-frame compile-frame env))
         (const runtime-env environment (cons runtime-frame env))
         (var result switch-guard ((eval :case-elements) runtime-env (new switch-key key) d))
         (rwhen (in result object :narrow-true)
           (return result))
         (assert (= result (new switch-key key) switch-guard))
         (<- result ((eval :case-elements) runtime-env default d))
         (rwhen (in result object :narrow-true)
           (return result))
         (assert (= result default switch-guard))
         (return d))))
    
    (rule :case-elements ((n-defaults integer)
                          (validate (-> (context environment jump-targets) void))
                          (setup (-> () void))
                          (eval (-> (environment switch-guard object) switch-guard)))
      (production :case-elements () case-elements-none
        (n-defaults 0)
        ((validate cxt env jt) :forward)
        ((setup) :forward)
        ((eval (env :unused) guard (d :unused)) (return guard)))
      (production :case-elements (:case-label) case-elements-one
        (n-defaults (n-defaults :case-label))
        ((validate cxt env jt) :forward)
        ((setup) :forward)
        ((eval env guard d)
         (return ((eval :case-label) env guard d))))
      (production :case-elements (:case-label :case-elements-prefix (:case-element abbrev)) case-elements-more
        (n-defaults (+ (n-defaults :case-label) (+ (n-defaults :case-elements-prefix) (n-defaults :case-element))))
        ((validate cxt env jt) :forward)
        ((setup) :forward)
        ((eval env guard d)
         (const guard2 switch-guard ((eval :case-label) env guard d))
         (const guard3 switch-guard ((eval :case-elements-prefix) env guard2 d))
         (return ((eval :case-element) env guard3 d)))))
    
    (rule :case-elements-prefix ((n-defaults integer)
                                 (validate (-> (context environment jump-targets) void))
                                 (setup (-> () void))
                                 (eval (-> (environment switch-guard object) switch-guard)))
      (production :case-elements-prefix () case-elements-prefix-none
        (n-defaults 0)
        ((validate cxt env jt) :forward)
        ((setup) :forward)
        ((eval (env :unused) guard (d :unused)) (return guard)))
      (production :case-elements-prefix (:case-elements-prefix (:case-element full)) case-elements-prefix-more
        (n-defaults (+ (n-defaults :case-elements-prefix) (n-defaults :case-element)))
        ((validate cxt env jt) :forward)
        ((setup) :forward)
        ((eval env guard d)
         (const guard2 switch-guard ((eval :case-elements-prefix) env guard d))
         (return ((eval :case-element) env guard2 d)))))
    
    (rule (:case-element :omega_2) ((n-defaults integer)
                                    (validate (-> (context environment jump-targets) void))
                                    (setup (-> () void))
                                    (eval (-> (environment switch-guard object) switch-guard)))
      (production (:case-element :omega_2) ((:directive :omega_2)) case-element-directive
        (n-defaults 0)
        ((validate cxt env jt) ((validate :directive) cxt env jt false none))
        ((setup) :forward)
        ((eval env guard (d :unused))
         (case guard
           (:narrow (union switch-key (tag default)) (return guard))
           (:narrow object
             (return ((eval :directive) env guard))))))
      (production (:case-element :omega_2) (:case-label) case-element-case-label
        (n-defaults (n-defaults :case-label))
        ((validate cxt env jt) ((validate :case-label) cxt env jt))
        ((setup) :forward)
        ((eval env guard d)
         (return ((eval :case-label) env guard d)))))
    
    (rule :case-label ((n-defaults integer)
                       (validate (-> (context environment jump-targets) void))
                       (setup (-> () void))
                       (eval (-> (environment switch-guard object) switch-guard)))
      (production :case-label (case (:list-expression allow-in) \:) case-label-case
        (n-defaults 0)
        ((validate cxt env (jt :unused)) ((validate :list-expression) cxt env))
        ((setup) :forward)
        ((eval env guard d)
         (case guard
           (:narrow (union (tag default) object) (return guard))
           (:narrow switch-key
             (const label object (read-reference ((eval :list-expression) env run) run))
             (if (is-strictly-equal (& key guard) label run)
               (return d)
               (return guard))))))
      (production :case-label (default \:) case-label-default
        (n-defaults 1)
        ((validate (cxt :unused) (env :unused) (jt :unused)))
        ((setup) :forward)
        ((eval (env :unused) guard d)
         (case guard
           (:narrow (union switch-key object) (return guard))
           (:narrow (tag default) (return d))))))
    (%print-actions ("Validation" n-defaults compile-frame validate) ("Setup" setup) ("Evaluation" eval))
    
    
    (%heading 2 "Do-While Statement")
    (rule :do-statement ((labels (writable-cell (list-set label)))
                         (validate (-> (context environment (list-set label) jump-targets) void))
                         (setup (-> () void))
                         (eval (-> (environment object) object)))
      (production :do-statement (do (:substatement abbrev) while :paren-list-expression) do-statement-do-while
        ((validate cxt env sl jt)
         (const continue-labels (list-set label) (set+ sl (list-set-of label default)))
         (action<- (labels :do-statement 0) continue-labels)
         (const jt2 jump-targets (new jump-targets
                                   (set+ (& break-targets jt) (list-set-of label default))
                                   (set+ (& continue-targets jt) continue-labels)))
         ((validate :substatement) cxt env (list-set-of label) jt2)
         ((validate :paren-list-expression) cxt env))
        ((setup) :forward)
        ((eval env d)
         (catch ((var d1 object d)
                 (while true
                   (catch ((<- d1 ((eval :substatement) env d1)))
                     (x) (if (and (in x continue :narrow-true) (set-in (& label x) (labels :do-statement 0)))
                           (<- d1 (& value x))
                           (throw x)))
                   (const o object (read-reference ((eval :paren-list-expression) env run) run))
                   (rwhen (not (object-to-boolean o))
                     (return d1))))
           (x) (if (and (in x break :narrow-true) (= (& label x) default label))
                 (return (& value x))
                 (throw x))))))
    (%print-actions ("Validation" labels validate) ("Setup" setup) ("Evaluation" eval))
    
    
    (%heading 2 "While Statement")
    (rule (:while-statement :omega) ((labels (writable-cell (list-set label)))
                                     (validate (-> (context environment (list-set label) jump-targets) void))
                                     (setup (-> () void))
                                     (eval (-> (environment object) object)))
      (production (:while-statement :omega) (while :paren-list-expression (:substatement :omega)) while-statement-while
        ((validate cxt env sl jt)
         (const continue-labels (list-set label) (set+ sl (list-set-of label default)))
         (action<- (labels :while-statement 0) continue-labels)
         (const jt2 jump-targets (new jump-targets
                                   (set+ (& break-targets jt) (list-set-of label default))
                                   (set+ (& continue-targets jt) continue-labels)))
         ((validate :paren-list-expression) cxt env)
         ((validate :substatement) cxt env (list-set-of label) jt2))
        ((setup) :forward)
        ((eval env d)
         (catch ((var d1 object d)
                 (while (object-to-boolean (read-reference ((eval :paren-list-expression) env run) run))
                   (catch ((<- d1 ((eval :substatement) env d1)))
                     (x) (if (and (in x continue :narrow-true) (set-in (& label x) (labels :while-statement 0)))
                           (<- d1 (& value x))
                           (throw x))))
                 (return d1))
           (x) (if (and (in x break :narrow-true) (= (& label x) default label))
                 (return (& value x))
                 (throw x))))))
    (%print-actions ("Validation" labels validate) ("Setup" setup) ("Evaluation" eval))
    
    
    (%heading 2 "For Statements")
    (rule (:for-statement :omega) ((labels (writable-cell (list-set label)))
                                   (compile-local-frame (writable-cell local-frame))
                                   (validate (-> (context environment (list-set label) jump-targets) void))
                                   (setup (-> () void))
                                   (eval (-> (environment object) object)))
      (production (:for-statement :omega) (for \( :for-initializer \; :optional-expression \; :optional-expression \)
                                               (:substatement :omega)) for-statement-c-style
        ((validate cxt env sl jt)
         (const continue-labels (list-set label) (set+ sl (list-set-of label default)))
         (action<- (labels :for-statement 0) continue-labels)
         (const jt2 jump-targets (new jump-targets
                                   (set+ (& break-targets jt) (list-set-of label default))
                                   (set+ (& continue-targets jt) continue-labels)))
         (const compile-local-frame local-frame (new local-frame (list-set-of local-binding)))
         (action<- (compile-local-frame :for-statement 0) compile-local-frame)
         (const compile-env environment (cons compile-local-frame env))
         ((validate :for-initializer) cxt compile-env)
         ((validate :optional-expression 1) cxt compile-env)
         ((validate :optional-expression 2) cxt compile-env)
         ((validate :substatement) cxt compile-env (list-set-of label) jt2))
        ((setup) :forward)
        ((eval env d)
         (const runtime-local-frame local-frame (instantiate-local-frame (compile-local-frame :for-statement 0) env))
         (const runtime-env environment (cons runtime-local-frame env))
         (catch (((eval :for-initializer) runtime-env)
                 (var d1 object d)
                 (while (object-to-boolean (read-reference ((eval :optional-expression 1) runtime-env run) run))
                   (catch ((<- d1 ((eval :substatement) runtime-env d1)))
                     (x) (if (and (in x continue :narrow-true) (set-in (& label x) (labels :for-statement 0)))
                           (<- d1 (& value x))
                           (throw x)))
                   (exec (read-reference ((eval :optional-expression 2) runtime-env run) run)))
                 (return d1))
           (x) (if (and (in x break :narrow-true) (= (& label x) default label))
                 (return (& value x))
                 (throw x)))))
      
      (production (:for-statement :omega) (for \( :for-in-binding in (:list-expression allow-in) \) (:substatement :omega)) for-statement-in
        ((validate cxt env sl jt)
         (const continue-labels (list-set label) (set+ sl (list-set-of label default)))
         (action<- (labels :for-statement 0) continue-labels)
         (const jt2 jump-targets (new jump-targets
                                   (set+ (& break-targets jt) (list-set-of label default))
                                   (set+ (& continue-targets jt) continue-labels)))
         ((validate :list-expression) cxt env)
         (const compile-local-frame local-frame (new local-frame (list-set-of local-binding)))
         (action<- (compile-local-frame :for-statement 0) compile-local-frame)
         (const compile-env environment (cons compile-local-frame env))
         ((validate :for-in-binding) cxt compile-env)
         ((validate :substatement) cxt compile-env (list-set-of label) jt2))
        ((setup) :forward)
        ((eval env d)
         (catch ((const o object (read-reference ((eval :list-expression) env run) run))
                 (const c class (object-type o))
                 (var old-indices (list-set object) ((& enumerate c) o))
                 (var remaining-indices (list-set object) old-indices)
                 (var d1 object d)
                 (while (nonempty remaining-indices)
                   (const runtime-local-frame local-frame (instantiate-local-frame (compile-local-frame :for-statement 0) env))
                   (const runtime-env environment (cons runtime-local-frame env))
                   (const index object (elt-of remaining-indices))
                   (<- remaining-indices (set- remaining-indices (list-set index)))
                   ((write-binding :for-in-binding) runtime-env index)
                   (catch ((<- d1 ((eval :substatement) runtime-env d1)))
                     (x) (if (and (in x continue :narrow-true) (set-in (& label x) (labels :for-statement 0)))
                           (<- d1 (& value x))
                           (throw x)))
                   (var new-indices (list-set object) ((& enumerate c) o))
                   (when (/= new-indices old-indices (list-set object))
                     (// "The implementation may, at its discretion, add none, some, or all of the objects in the set difference "
                         (:expr (list-set object) (set- new-indices old-indices)) " to " (:local remaining-indices) ";")
                     (// "The implementation may, at its discretion, remove none, some, or all of the objects in the set difference "
                         (:expr (list-set object) (set- old-indices new-indices)) " from " (:local remaining-indices) ";"))
                   (<- old-indices new-indices))
                 (return d1))
           (x) (if (and (in x break :narrow-true) (= (& label x) default label))
                 (return (& value x))
                 (throw x))))))
    
    
    (rule :for-initializer ((enabled (writable-cell boolean))
                            (validate (-> (context environment) void))
                            (setup (-> () void))
                            (eval (-> (environment) void)))
      (production :for-initializer () for-initializer-empty
        ((validate (cxt :unused) (env :unused)))
        ((setup))
        ((eval (env :unused))))
      (production :for-initializer ((:list-expression no-in)) for-initializer-expression
        ((validate cxt env) ((validate :list-expression) cxt env))
        ((setup) ((setup :list-expression)))
        ((eval env) (exec (read-reference ((eval :list-expression) env run) run))))
      (production :for-initializer ((:variable-definition no-in)) for-initializer-variable-definition
        ((validate cxt env) ((validate :variable-definition) cxt env none))
        ((setup) ((setup :variable-definition)))
        ((eval env) (exec ((eval :variable-definition) env undefined))))
      (production :for-initializer (:attributes :no-line-break (:variable-definition no-in)) for-initializer-attribute-variable-definition
        ((validate cxt env)
         ((validate :attributes) cxt env)
         ((setup :attributes))
         (const attr attribute ((eval :attributes) env compile))
         (action<- (enabled :for-initializer 0) (not-in attr false-type))
         (when (not-in attr false-type :narrow-true)
           ((validate :variable-definition) cxt env attr)))
        ((setup)
         (when (enabled :for-initializer 0)
           ((setup :variable-definition))))
        ((eval env)
         (when (enabled :for-initializer 0)
           (exec ((eval :variable-definition) env undefined))))))
    
    
    (rule :for-in-binding ((validate (-> (context environment) void))
                           (setup (-> () void))
                           (write-binding (-> (environment object) void)))
      (production :for-in-binding (:postfix-expression) for-in-binding-expression
        ((validate cxt env) ((validate :postfix-expression) cxt env))
        ((setup) ((setup :postfix-expression)))
        ((write-binding env new-value)
         (const r obj-or-ref ((eval :postfix-expression) env run))
         (exec (write-reference r new-value run))))
      (production :for-in-binding (:variable-definition-kind (:variable-binding no-in)) for-in-binding-variable-definition
        ((validate cxt env) ((validate :variable-binding) cxt env none (immutable :variable-definition-kind) true))
        ((setup) ((setup :variable-binding)))
        ((write-binding env new-value) ((write-binding :variable-binding) env new-value)))
      (production :for-in-binding (:attributes :no-line-break :variable-definition-kind (:variable-binding no-in)) for-in-binding-attribute-variable-definition
        ((validate cxt env)
         ((validate :attributes) cxt env)
         ((setup :attributes))
         (const attr attribute ((eval :attributes) env compile))
         (rwhen (in attr false-type :narrow-false)
           (throw-error -attribute-error
             "the " (:character-literal "false") " attribute canot be applied to a " (:character-literal "for") "-" (:character-literal "in") " variable definition"))
         ((validate :variable-binding) cxt env attr (immutable :variable-definition-kind) true))
        ((setup) ((setup :variable-binding)))
        ((write-binding env new-value) ((write-binding :variable-binding) env new-value))))
    
    
    (rule :optional-expression ((validate (-> (context environment) void)) (setup (-> () void))
                                (eval (-> (environment phase) obj-or-ref)))
      (production :optional-expression ((:list-expression allow-in)) optional-expression-expression
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase) (return ((eval :list-expression) env phase))))
      (production :optional-expression () optional-expression-empty
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval (env :unused) (phase :unused)) (return true))))
    (%print-actions ("Validation" enabled labels compile-local-frame validate) ("Setup" setup) ("Evaluation" eval write-binding))
    
    
    (%heading 2 "With Statement")
    (rule (:with-statement :omega) ((compile-local-frame (writable-cell local-frame))
                                    (validate (-> (context environment jump-targets) void)) (setup (-> () void))
                                    (eval (-> (environment object) object)))
      (production (:with-statement :omega) (with :paren-list-expression (:substatement :omega)) with-statement-with
        ((validate cxt env jt)
         ((validate :paren-list-expression) cxt env)
         (const compile-with-frame with-frame (new with-frame none))
         (const compile-local-frame local-frame (new local-frame (list-set-of local-binding)))
         (action<- (compile-local-frame :with-statement 0) compile-local-frame)
         (const compile-env environment (cons compile-local-frame (cons compile-with-frame env)))
         ((validate :substatement) cxt compile-env (list-set-of label) jt))
        ((setup) :forward)
        ((eval env d)
         (const value object (read-reference ((eval :paren-list-expression) env run) run))
         (const runtime-with-frame with-frame (new with-frame value))
         (const runtime-local-frame local-frame (instantiate-local-frame (compile-local-frame :with-statement 0) (cons runtime-with-frame env)))
         (const runtime-env environment (cons runtime-local-frame (cons runtime-with-frame env)))
         (return ((eval :substatement) runtime-env d)))))
    (%print-actions ("Validation" compile-local-frame validate) ("Setup" setup) ("Evaluation" eval))
    
    
    (%heading 2 "Continue and Break Statements")
    (rule :continue-statement ((validate (-> (jump-targets) void)) (setup (-> () void))
                               (eval (-> (environment object) object)))
      (production :continue-statement (continue) continue-statement-unlabeled
        ((validate jt)
         (rwhen (set-not-in default (& continue-targets jt))
           (throw-error -syntax-error "there is no enclosing statement to which to continue")))
        ((setup))
        ((eval (env :unused) d) (throw (new continue d default))))
      (production :continue-statement (continue :no-line-break :identifier) continue-statement-labeled
        ((validate jt)
         (rwhen (set-not-in (name :identifier) (& continue-targets jt))
           (throw-error -syntax-error "there is no enclosing labeled statement to which to continue")))
        ((setup))
        ((eval (env :unused) d) (throw (new continue d (name :identifier))))))
    
    (rule :break-statement ((validate (-> (jump-targets) void)) (setup (-> () void))
                            (eval (-> (environment object) object)))
      (production :break-statement (break) break-statement-unlabeled
        ((validate jt)
         (rwhen (set-not-in default (& break-targets jt))
           (throw-error -syntax-error "there is no enclosing statement to which to break")))
        ((setup))
        ((eval (env :unused) d) (throw (new break d default))))
      (production :break-statement (break :no-line-break :identifier) break-statement-labeled
        ((validate jt)
         (rwhen (set-not-in (name :identifier) (& break-targets jt))
           (throw-error -syntax-error "there is no enclosing labeled statement to which to break")))
        ((setup))
        ((eval (env :unused) d) (throw (new break d (name :identifier))))))
    (%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
    
    
    (%heading 2 "Return Statement")
    (rule :return-statement ((validate (-> (context environment) void)) (setup (-> () void))
                             (eval (-> (environment) object)))
      (production :return-statement (return) return-statement-default
        ((validate (cxt :unused) env)
         (rwhen (in (get-enclosing-parameter-frame env) (tag none))
           (throw-error -syntax-error "a " (:character-literal "return") " statement must be located inside a function")))
        ((setup) :forward)
        ((eval (env :unused)) (throw (new return undefined))))
      (production :return-statement (return :no-line-break (:list-expression allow-in)) return-statement-expression
        ((validate cxt env)
         (const frame parameter-frame-opt (get-enclosing-parameter-frame env))
         (rwhen (in frame (tag none) :narrow-false)
           (throw-error -syntax-error "a " (:character-literal "return") " statement must be located inside a function"))
         (rwhen (cannot-return-value frame)
           (throw-error -syntax-error "a " (:character-literal "return") " statement inside a setter or constructor cannot return a value"))
         ((validate :list-expression) cxt env))
        ((setup) :forward)
        ((eval env)
         (const a object (read-reference ((eval :list-expression) env run) run))
         (throw (new return a)))))
    (%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
    
    (%text :comment (:global-call cannot-return-value frame) " returns " (:tag true) " if the function represented by " (:local frame)
           " cannot return a value because it is a setter or constructor.")
    (define (cannot-return-value (frame parameter-frame)) boolean
      (return (or (in (& kind frame) (tag constructor-function)) (in (& handling frame) (tag set)))))
    
    
    (%heading 2 "Throw Statement")
    (rule :throw-statement ((validate (-> (context environment) void)) (setup (-> () void))
                            (eval (-> (environment) object)))
      (production :throw-statement (throw :no-line-break (:list-expression allow-in)) throw-statement-throw
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env)
         (const a object (read-reference ((eval :list-expression) env run) run))
         (throw a))))
    (%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
    
    
    (%heading 2 "Try Statement")
    (rule :try-statement ((validate (-> (context environment jump-targets) void)) (setup (-> () void))
                          (eval (-> (environment object) object)))
      (production :try-statement (try :block :catch-clauses) try-statement-catch-clauses
        ((validate cxt env jt)
         ((validate :block) cxt env jt false)
         ((validate :catch-clauses) cxt env jt))
        ((setup) :forward)
        ((eval env d)
         (catch ((return ((eval :block) env d)))
           (x)
           (cond
            ((in x control-transfer :narrow-false) (throw x))
            (nil 
             (const r (union object (tag reject)) ((eval :catch-clauses) env x))
             (if (not-in r (tag reject) :narrow-true)
               (return r)
               (throw x)))))))
      
      (production :try-statement (try :block :catch-clauses-opt finally :block) try-statement-catch-clauses-finally
        ((validate cxt env jt)
         ((validate :block 1) cxt env jt false)
         ((validate :catch-clauses-opt) cxt env jt)
         ((validate :block 2) cxt env jt false))
        ((setup) :forward)
        ((eval env d)
         (var result object-opt none)
         (var exception (union semantic-exception (tag none)) none)
         (catch ((<- result ((eval :block 1) env d)))
           (x) (<- exception x))
         (assert (xor (in result (tag none)) (in exception (tag none))) "At this point exactly one of " (:local result) " and " (:local exception) " has a non-" (:tag none) " value.")
         (when (in exception object)
           (catch ((const r (union object (tag reject)) ((eval :catch-clauses-opt) env (assert-in exception object)))
                   (when (not-in r (tag reject) :narrow-true)
                     (note "The exception has been handled, so clear it.")
                     (<- result r)
                     (<- exception none)))
             (x)
             (note "The " (:character-literal "catch") " clause threw another exception or " (:type control-transfer) " " (:local x) ", so replace the original exception with " (:local x) ".")
             (<- exception x)))
         (note "The " (:character-literal "finally") " clause is executed even if the original block exited due to a " (:type control-transfer) " ("
               (:character-literal "break") ", " (:character-literal "continue") ", or " (:character-literal "return") ").")
         (note "The " (:character-literal "finally") " clause is not inside a " (:keyword try) "-" (:keyword catch)
               " semantic statement, so if it throws another exception or " (:type control-transfer) ", then the original exception or " (:type control-transfer) " "
               (:local exception) " is dropped.")
         (exec ((eval :block 2) env undefined))
         (assert (xor (in result (tag none)) (in exception (tag none))) "At this point exactly one of " (:local result) " and " (:local exception) " has a non-" (:tag none) " value.")
         (if (not-in exception (tag none) :narrow-true)
           (throw exception)
           (return (assert-not-in result (tag none)))))))
    
    (rule :catch-clauses-opt ((validate (-> (context environment jump-targets) void)) (setup (-> () void))
                              (eval (-> (environment object) (union object (tag reject)))))
      (production :catch-clauses-opt () catch-clauses-opt-none
        ((validate cxt env jt) :forward)
        ((setup) :forward)
        ((eval (env :unused) (exception :unused))
         (return reject)))
      (production :catch-clauses-opt (:catch-clauses) catch-clauses-opt-some
        ((validate cxt env jt) :forward)
        ((setup) :forward)
        ((eval env exception)
         (return ((eval :catch-clauses) env exception)))))
    
    (rule :catch-clauses ((validate (-> (context environment jump-targets) void)) (setup (-> () void))
                          (eval (-> (environment object) (union object (tag reject)))))
      (production :catch-clauses (:catch-clause) catch-clauses-one
        ((validate cxt env jt) :forward)
        ((setup) :forward)
        ((eval env exception)
         (return ((eval :catch-clause) env exception))))
      (production :catch-clauses (:catch-clauses :catch-clause) catch-clauses-more
        ((validate cxt env jt) :forward)
        ((setup) :forward)
        ((eval env exception)
         (const r (union object (tag reject)) ((eval :catch-clauses) env exception))
         (if (not-in r (tag reject) :narrow-true)
           (return r)
           (return ((eval :catch-clause) env exception))))))
    
    (rule :catch-clause ((compile-env (writable-cell environment))
                         (compile-frame (writable-cell local-frame))
                         (validate (-> (context environment jump-targets) void)) (setup (-> () void))
                         (eval (-> (environment object) (union object (tag reject)))))
      (production :catch-clause (catch \( :parameter \) :block) catch-clause-block
        ((validate cxt env jt)
         (const compile-frame local-frame (new local-frame (list-set-of local-binding)))
         (const compile-env environment (cons compile-frame env))
         (action<- (compile-frame :catch-clause 0) compile-frame)
         (action<- (compile-env :catch-clause 0) compile-env)
         ((validate :parameter) cxt compile-env compile-frame)
         ((validate :block) cxt compile-env jt false))
        ((setup)
         ((setup :parameter) (compile-env :catch-clause 0) (compile-frame :catch-clause 0) none)
         ((setup :block)))
        ((eval env exception)
         (const compile-frame local-frame (compile-frame :catch-clause 0))
         (const runtime-frame local-frame (instantiate-local-frame compile-frame env))
         (const runtime-env environment (cons runtime-frame env))
         (const qname qualified-name (new qualified-name public (name :parameter)))
         (const v singleton-property-opt (find-local-singleton-property runtime-frame (list-set qname) write))
         (assert (in v variable :narrow-true) (:action validate) " created one local variable with the name in " (:local qname) ", so " (:assertion) ".")
         (cond
          ((is exception (&opt type v))
           (write-singleton-property v exception run)
           (return ((eval :block) runtime-env undefined)))
          (nil (return reject))))))
    (%print-actions ("Validation" compile-env compile-frame validate) ("Setup" setup) ("Evaluation" eval))
    
    
    (%heading 1 "Directives")
    (rule (:directive :omega_2) ((enabled (writable-cell boolean))
                                 (validate (-> (context environment jump-targets boolean attribute-opt-not-false) void))
                                 (setup (-> () void))
                                 (eval (-> (environment object) object)))
      (production (:directive :omega_2) (:empty-statement) directive-empty-statement
        ((validate (cxt :unused) (env :unused) (jt :unused) (preinst :unused) (attr :unused)))
        ((setup))
        ((eval (env :unused) d) (return d)))
      (production (:directive :omega_2) ((:statement :omega_2)) directive-statement
        ((validate cxt env jt preinst attr)
         (rwhen (not-in attr (tag none true))
           (throw-error -attribute-error "an ordinary statement only permits the attributes " (:character-literal "true") " and " (:character-literal "false")))
         ((validate :statement) cxt env (list-set-of label) jt preinst))
        ((setup) ((setup :statement)))
        ((eval env d) (return ((eval :statement) env d))))
      (production (:directive :omega_2) ((:annotatable-directive :omega_2)) directive-annotatable-directive
        ((validate cxt env (jt :unused) preinst attr) ((validate :annotatable-directive) cxt env preinst attr))
        ((setup) ((setup :annotatable-directive)))
        ((eval env d) (return ((eval :annotatable-directive) env d))))
      (production (:directive :omega_2) (:attributes :no-line-break (:annotatable-directive :omega_2)) directive-attributes-and-directive
        ((validate cxt env (jt :unused) preinst attr)
         ((validate :attributes) cxt env)
         ((setup :attributes))
         (const attr2 attribute ((eval :attributes) env compile))
         (const attr3 attribute (combine-attributes attr attr2))
         (cond
          ((in attr3 false-type :narrow-false)
           (action<- (enabled :directive 0) false))
          (nil
           (action<- (enabled :directive 0) true)
           ((validate :annotatable-directive) cxt env preinst attr3))))
        ((setup)
         (when (enabled :directive 0)
           ((setup :annotatable-directive))))
        ((eval env d)
         (if (enabled :directive 0)
           (return ((eval :annotatable-directive) env d))
           (return d))))
      (production (:directive :omega_2) (:attributes :no-line-break { :directives }) directive-annotated-group
        ((validate cxt env jt preinst attr)
         ((validate :attributes) cxt env)
         ((setup :attributes))
         (const attr2 attribute ((eval :attributes) env compile))
         (const attr3 attribute (combine-attributes attr attr2))
         (cond
          ((in attr3 false-type :narrow-false)
           (action<- (enabled :directive 0) false))
          (nil
           (action<- (enabled :directive 0) true)
           (const local-cxt context (new context (& strict cxt) (& open-namespaces cxt)))
           ((validate :directives) local-cxt env jt preinst attr3))))
        ((setup)
         (when (enabled :directive 0)
           ((setup :directives))))
        ((eval env d)
         (if (enabled :directive 0)
           (return ((eval :directives) env d))
           (return d))))
      (? js2
        (production (:directive :omega_2) (:include-directive (:semicolon :omega_2)) directive-include-directive
          ((validate (cxt :unused) (env :unused) (jt :unused) (preinst :unused) attr)
           (if (in attr (tag none true))
             (todo)
             (throw-error -attribute-error "an " (:character-literal "include") " directive only permits the attributes " (:character-literal "true") " and " (:character-literal "false"))))
          ((setup) (todo))
          ((eval (env :unused) (d :unused)) (todo))))
      (production (:directive :omega_2) (:pragma (:semicolon :omega_2)) directive-pragma
        ((validate cxt (env :unused) (jt :unused) (preinst :unused) attr)
         (if (in attr (tag none true))
           ((validate :pragma) cxt)
           (throw-error -attribute-error "a " (:character-literal "pragma") " directive only permits the attributes " (:character-literal "true") " and " (:character-literal "false"))))
        ((setup))
        ((eval (env :unused) d) (return d))))
    
    (rule (:annotatable-directive :omega_2) ((validate (-> (context environment boolean attribute-opt-not-false) void))
                                             (setup (-> () void))
                                             (eval (-> (environment object) object)))
      (production (:annotatable-directive :omega_2) ((:variable-definition allow-in) (:semicolon :omega_2)) annotatable-directive-variable-definition
        ((validate cxt env (preinst :unused) attr) ((validate :variable-definition) cxt env attr))
        ((setup) ((setup :variable-definition)))
        ((eval env d) (return ((eval :variable-definition) env d))))
      (production (:annotatable-directive :omega_2) (:function-definition) annotatable-directive-function-definition
        ((validate cxt env preinst attr) ((validate :function-definition) cxt env preinst attr))
        ((setup) ((setup :function-definition)))
        ((eval (env :unused) d) (return d)))
      (production (:annotatable-directive :omega_2) (:class-definition) annotatable-directive-class-definition
        ((validate cxt env preinst attr) ((validate :class-definition) cxt env preinst attr))
        ((setup) ((setup :class-definition)))
        ((eval env d) (return ((eval :class-definition) env d))))
      (production (:annotatable-directive :omega_2) (:namespace-definition (:semicolon :omega_2)) annotatable-directive-namespace-definition
        ((validate cxt env preinst attr) ((validate :namespace-definition) cxt env preinst attr))
        ((setup))
        ((eval (env :unused) d) (return d)))
      ;(production (:annotatable-directive :omega_2) ((:interface-definition :omega_2)) annotatable-directive-interface-definition
      ;  ((validate (cxt :unused) (env :unused) (preinst :unused) (attr :unused)) (todo))
      ;  ((setup) (todo))
      ;  ((eval (env :unused) (d :unused)) (todo)))
      (production (:annotatable-directive :omega_2) (:import-directive (:semicolon :omega_2)) annotatable-directive-import-directive
        ((validate cxt env preinst attr) ((validate :import-directive) cxt env preinst attr))
        ((setup))
        ((eval (env :unused) d) (return d)))
      (? js2
        (production (:annotatable-directive :omega_2) (:export-definition (:semicolon :omega_2)) annotatable-directive-export-definition
          ((validate (cxt :unused) (env :unused) (preinst :unused) (attr :unused)) (todo))
          ((setup) (todo))
          ((eval (env :unused) (d :unused)) (todo))))
      (production (:annotatable-directive :omega_2) (:use-directive (:semicolon :omega_2)) annotatable-directive-use-directive
        ((validate cxt env (preinst :unused) attr)
         (if (in attr (tag none true))
           ((validate :use-directive) cxt env)
           (throw-error -attribute-error
             "a " (:character-literal "use") " directive only permits the attributes " (:character-literal "true") " and " (:character-literal "false"))))
        ((setup))
        ((eval (env :unused) d) (return d))))
    
    
    (rule :directives ((validate (-> (context environment jump-targets boolean attribute-opt-not-false) void)) (setup (-> () void))
                       (eval (-> (environment object) object)))
      (production :directives () directives-none
        ((validate cxt env jt preinst attr) :forward)
        ((setup) :forward)
        ((eval (env :unused) d) (return d)))
      (production :directives (:directives-prefix (:directive abbrev)) directives-more
        ((validate cxt env jt preinst attr) :forward)
        ((setup) :forward)
        ((eval env d)
         (const o object ((eval :directives-prefix) env d))
         (return ((eval :directive) env o)))))
    
    (rule :directives-prefix ((validate (-> (context environment jump-targets boolean attribute-opt-not-false) void)) (setup (-> () void))
                              (eval (-> (environment object) object)))
      (production :directives-prefix () directives-prefix-none
        ((validate cxt env jt preinst attr) :forward)
        ((setup) :forward)
        ((eval (env :unused) d) (return d)))
      (production :directives-prefix (:directives-prefix (:directive full)) directives-prefix-more
        ((validate cxt env jt preinst attr) :forward)
        ((setup) :forward)
        ((eval env d)
         (const o object ((eval :directives-prefix) env d))
         (return ((eval :directive) env o)))))
    (%print-actions ("Validation" enabled validate) ("Setup" setup) ("Evaluation" eval))
    
    
    (%heading 2 "Attributes")
    (rule :attributes ((validate (-> (context environment) void)) (setup (-> () void))
                       (eval (-> (environment phase) attribute)))
      (production :attributes (:attribute) attributes-one
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase) (return ((eval :attribute) env phase))))
      (production :attributes (:attribute-combination) attributes-attribute-combination
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase) (return ((eval :attribute-combination) env phase)))))
    
    
    (rule :attribute-combination ((validate (-> (context environment) void)) (setup (-> () void))
                                  (eval (-> (environment phase) attribute)))
      (production :attribute-combination (:attribute :no-line-break :attributes) attribute-combination-more
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const a attribute ((eval :attribute) env phase))
         (rwhen (in a false-type :narrow-false)
           (return false))
         (const b attribute ((eval :attributes) env phase))
         (return (combine-attributes a b)))))
    
    
    (rule :attribute ((validate (-> (context environment) void)) (setup (-> () void))
                      (eval (-> (environment phase) attribute)))
      (production :attribute (:attribute-expression) attribute-attribute-expression
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (const a object (read-reference ((eval :attribute-expression) env phase) phase))
         (return (object-to-attribute a phase))))
      (production :attribute (true) attribute-true
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval (env :unused) (phase :unused)) (return true)))
      (production :attribute (false) attribute-false
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval (env :unused) (phase :unused)) (return false)))
      (production :attribute (:reserved-namespace) attribute-reserved-namespace
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase) (return ((eval :reserved-namespace) env phase)))))
    (%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
    
    
    
    (%heading 2 "Use Directive")
    (rule :use-directive ((validate (-> (context environment) void)))
      (production :use-directive (use namespace :paren-list-expression) use-directive-normal
        ((validate cxt env)
         ((validate :paren-list-expression) cxt env)
         ((setup :paren-list-expression))
         (const values (vector object) ((eval-as-list :paren-list-expression) env compile))
         (var namespaces (list-set namespace) (list-set-of namespace))
         (for-each values v
           (rwhen (not-in v namespace :narrow-false)
             (throw-error -type-error))
           (<- namespaces (set+ namespaces (list-set v))))
         (&= open-namespaces cxt (set+ (& open-namespaces cxt) namespaces)))))
    (%print-actions ("Validation" validate))
    
    
    (%heading 2 "Import Directive")
    (rule :import-directive ((validate (-> (context environment boolean attribute-opt-not-false) void)))
      (production :import-directive (import :package-name) import-directive-unnamed
        ((validate (cxt :unused) env preinst attr)
         (rwhen (not preinst)
           (throw-error -syntax-error "a package may be imported only in a preinstantiated scope"))
         (const frame frame (nth env 0))
         (rwhen (not-in frame package :narrow-false)
           (throw-error -syntax-error "a package may be imported only into a package scope"))
         (rwhen (not-in attr (tag none true))
           (throw-error -attribute-error
             "an unnamed " (:character-literal "import") " directive only permits the attributes " (:character-literal "true") " and " (:character-literal "false")))
         (const pkg-name string (name :package-name))
         (const pkg package (locate-package pkg-name))
         (import-package-into pkg frame)))
      (production :import-directive (import :identifier = :package-name) import-directive-named
        ((validate (cxt :unused) env preinst attr)
         (rwhen (not preinst)
           (throw-error -syntax-error "a package may be imported only in a preinstantiated scope"))
         (const frame frame (nth env 0))
         (rwhen (not-in frame package :narrow-false)
           (throw-error -syntax-error "a package may be imported only into a package scope"))
         (const a compound-attribute (to-compound-attribute attr))
         (rwhen (& dynamic a)
           (throw-error -attribute-error "a package definition cannot have the " (:character-literal "dynamic") " attribute"))
         (rwhen (& prototype a)
           (throw-error -attribute-error "a package definition cannot have the " (:character-literal "prototype") " attribute"))
         (const pkg-name string (name :package-name))
         (const pkg package (locate-package pkg-name))
         (const v variable (new variable -package pkg true none none :uninit))
         (exec (define-singleton-property env (name :identifier) (& namespaces a) (& override-mod a) (& explicit a) read-write v))
         (import-package-into pkg frame))))
    (%print-actions ("Validation" validate))
    
    
    (define (locate-package (name string)) package
      (/* "Look for a package bound to " (:local name) " in the implementation" :apostrophe "s list of available packages. "
          "If one is found, let " (:local pkg) ":" :nbsp (:type package) " be that package; otherwise, throw an implementation-defined error.")
      (var pkg (union package (tag none)) none)
      (reserve pkg2)
      (when (some package-database pkg2 (= (& name pkg2) name string) :define-true)
        (<- pkg pkg2))
      (rwhen (in pkg (tag none) :narrow-false)
        (throw-error -error "package not found"))
      (*/)
      (const initialize (union (-> () void) (tag none busy)) (& initialize pkg))
      (case initialize
        (:select (tag none))
        (:select (tag busy) (throw-error -uninitialized-error "circular package dependency"))
        (:narrow (-> () void)
          (initialize)
          (assert (in (& initialize pkg) (tag none)))))
      (return pkg))
    
    
    (define (import-package-into (source package) (destination package)) void
      (for-each (& local-bindings source) b
        (when (not (or (& explicit b)
                       (in (& content b) (tag forbidden))
                       (some (& local-bindings destination) d (and (= (& qname b) (& qname d) qualified-name) (accesses-overlap (& accesses b) (& accesses d))))))
          (&= local-bindings destination (set+ (& local-bindings destination) (list-set b))))))
    
    
      #|
      (%heading 2 "Import Directive")
      (production :import-directive (import :import-binding :includes-excludes) import-directive-import)
      (production :import-directive (import :import-binding \, namespace :paren-list-expression :includes-excludes)
                  import-directive-import-namespaces)
      
      (production :import-binding (:package-name) import-binding-import-source)
      (production :import-binding (:identifier = :package-name) import-binding-named-import-source)
      
      
      (production :includes-excludes () includes-excludes-none)
      (production :includes-excludes (\, exclude \( :name-patterns \)) includes-excludes-exclude-list)
      (production :includes-excludes (\, include \( :name-patterns \)) includes-excludes-include-list)
      
      (production :name-patterns () name-patterns-empty)
      (production :name-patterns (:name-pattern-list) name-patterns-name-pattern-list)
      
      (production :name-pattern-list (:qualified-identifier) name-pattern-list-one)
      (production :name-pattern-list (:name-pattern-list \, :qualified-identifier) name-pattern-list-more)
      
      
      (production :name-patterns (:name-pattern) name-patterns-one)
      (production :name-patterns (:name-patterns \, :name-pattern) name-patterns-more)
      
      (production :name-pattern (:qualified-wildcard-pattern) name-pattern-qualified-wildcard-pattern)
      (production :name-pattern (:full-postfix-expression \. :qualified-wildcard-pattern) name-pattern-dot-qualified-wildcard-pattern)
      (production :name-pattern (:attribute-expression \. :qualified-wildcard-pattern) name-pattern-dot-qualified-wildcard-pattern2)
      
      (production :qualified-wildcard-pattern (:qualified-identifier) qualified-wildcard-pattern-qualified-identifier)
      (production :qualified-wildcard-pattern (:wildcard-pattern) qualified-wildcard-pattern-wildcard-pattern)
      (production :qualified-wildcard-pattern (:qualifier \:\: :wildcard-pattern) qualified-wildcard-pattern-qualifier)
      (production :qualified-wildcard-pattern (:paren-expression \:\: :wildcard-pattern) qualified-wildcard-pattern-expression-qualifier)
      
      (production :wildcard-pattern (*) wildcard-pattern-all)
      (production :wildcard-pattern ($regular-expression) wildcard-pattern-regular-expression)
      |#
      
      
    (? js2
      (%heading 2 "Include Directive")
      (production :include-directive (include :no-line-break $string) include-directive-include))
    
    
    (%heading 2 "Pragma")
    (rule :pragma ((validate (-> (context) void)))
      (production :pragma (use :pragma-items) pragma-pragma-items
        ((validate cxt) :forward)))
    
    (rule :pragma-items ((validate (-> (context) void)))
      (production :pragma-items (:pragma-item) pragma-items-one
        ((validate cxt) :forward))
      (production :pragma-items (:pragma-items \, :pragma-item) pragma-items-more
        ((validate cxt) :forward)))
    
    (rule :pragma-item ((validate (-> (context) void)))
      (production :pragma-item (:pragma-expr) pragma-item-pragma-expr
        ((validate cxt) ((validate :pragma-expr) cxt false)))
      (production :pragma-item (:pragma-expr \?) pragma-item-optional-pragma-expr
        ((validate cxt) ((validate :pragma-expr) cxt true))))
    
    (rule :pragma-expr ((validate (-> (context boolean) void)))
      (production :pragma-expr (:identifier) pragma-expr-identifier
        ((validate cxt optional)
         (process-pragma cxt (name :identifier) undefined optional)))
      (production :pragma-expr (:identifier \( :pragma-argument \)) pragma-expr-identifier-and-parameter
        ((validate cxt optional)
         (const arg object (value :pragma-argument))
         (process-pragma cxt (name :identifier) arg optional))))
    
    (rule :pragma-argument ((value object))
      (production :pragma-argument (true) pragma-argument-true (value true))
      (production :pragma-argument (false) pragma-argument-false (value false))
      (production :pragma-argument ($number) pragma-argument-number (value (value $number)))
      (production :pragma-argument (- $number) pragma-argument-negative-number (value (general-number-negate (value $number))))
      (production :pragma-argument (- $negated-min-long) pragma-argument-min-long (value (new long (neg (expt 2 63)))))
      (production :pragma-argument ($string) pragma-argument-string (value (value $string))))
    (%print-actions ("Validation" validate))
    
    (define (process-pragma (cxt context) (name string) (value object) (optional boolean)) void
      (when (= name "strict" string)
        (rwhen (in value (tag true undefined) :narrow-false)
          (&= strict cxt true)
          (return))
        (rwhen (in value (tag false))
          (&= strict cxt false)
          (return)))
      (when (= name "ecmascript" string)
        (rwhen (set-in value (list-set-of object undefined 4.0))
          (return))
        (rwhen (set-in value (list-set-of object 1.0 2.0 3.0))
          (// "An implementation may optionally modify " (:local cxt) " to disable features not available in ECMAScript Edition " (:local value)
              " other than subsequent pragmas.")
          (return)))
      (rwhen (not optional)
        (throw-error -syntax-error)))
    
    
    (%heading 1 "Definitions")
    (? js2
      (%heading 2 "Export Definition")
      (production :export-definition (export :export-binding-list) export-definition-definition)
      
      (production :export-binding-list (:export-binding) export-binding-list-one)
      (production :export-binding-list (:export-binding-list \, :export-binding) export-binding-list-more)
      
      (production :export-binding (:function-name) export-binding-simple)
      (production :export-binding (:function-name = :function-name) export-binding-initializer))
    
    
    (%heading 2 "Variable Definition")
    (rule (:variable-definition :beta) ((validate (-> (context environment attribute-opt-not-false) void)) (setup (-> () void))
                                        (eval (-> (environment object) object)))
      (production (:variable-definition :beta) (:variable-definition-kind (:variable-binding-list :beta)) variable-definition-definition
        ((validate cxt env attr)
         ((validate :variable-binding-list) cxt env attr (immutable :variable-definition-kind) false))
        ((setup) ((setup :variable-binding-list)))
        ((eval env d)
         ((eval :variable-binding-list) env)
         (return d))))
    
    (rule :variable-definition-kind ((immutable boolean))
      (production :variable-definition-kind (var) variable-definition-kind-var (immutable false))
      (production :variable-definition-kind (const) variable-definition-kind-const (immutable true)))
    
    (rule (:variable-binding-list :beta) ((validate (-> (context environment attribute-opt-not-false boolean boolean) void))
                                          (setup (-> () void))
                                          (eval (-> (environment) void)))
      (production (:variable-binding-list :beta) ((:variable-binding :beta)) variable-binding-list-one
        ((validate cxt env attr immutable no-initializer) :forward)
        ((setup) :forward)
        ((eval env) :forward))
      (production (:variable-binding-list :beta) ((:variable-binding-list :beta) \, (:variable-binding :beta)) variable-binding-list-more
        ((validate cxt env attr immutable no-initializer) :forward)
        ((setup) :forward)
        ((eval env) :forward)))
    
    
    (rule (:variable-binding :beta) ((compile-env (writable-cell environment))
                                     (compile-var (writable-cell (union variable dynamic-var instance-variable)))
                                     (overridden-var (writable-cell instance-variable-opt))
                                     (multiname (writable-cell multiname))
                                     (validate (-> (context environment attribute-opt-not-false boolean boolean) void))
                                     (setup (-> () void))
                                     (eval (-> (environment) void))
                                     (write-binding (-> (environment object) void)))
      (production (:variable-binding :beta) ((:typed-identifier :beta) (:variable-initialisation :beta)) variable-binding-full
        ((validate cxt env attr immutable no-initializer)
         ((validate :typed-identifier) cxt env)
         ((validate :variable-initialisation) cxt env)
         (action<- (compile-env :variable-binding 0) env)
         (const name string (name :typed-identifier))
         (cond
          ((and (not (& strict cxt)) (in (get-regional-frame env) (union package parameter-frame))
                (not immutable) (in attr (tag none)) (plain :typed-identifier))
           (const qname qualified-name (new qualified-name public name))
           (action<- (multiname :variable-binding 0) (list-set qname))
           (action<- (compile-var :variable-binding 0) (define-hoisted-var env name undefined)))
          (nil
           (const a compound-attribute (to-compound-attribute attr))
           (rwhen (& dynamic a)
             (throw-error -attribute-error "a variable definition cannot have the " (:character-literal "dynamic") " attribute"))
           (rwhen (& prototype a)
             (throw-error -attribute-error "a variable definition cannot have the " (:character-literal "prototype") " attribute"))
           (var category property-category (& category a))
           (if (in (nth env 0) class)
             (when (in category (tag none))
               (<- category final))
             (rwhen (not-in category (tag none))
               (throw-error -attribute-error
                 "non-class variables cannot have a " (:character-literal "static") ", " (:character-literal "virtual") ", or "
                 (:character-literal "final") " attribute")))
           (case category
             (:select (tag none static)
               (const initializer initializer-opt (initializer :variable-initialisation))
               (rwhen (and no-initializer (not-in initializer (tag none)))
                 (throw-error -syntax-error
                   "a " (:character-literal "for") "-" (:character-literal "in") " statement" :apostrophe "s variable definition must not have an initialiser"))
               (function (variable-setup) class-opt
                 (const type class-opt ((setup-and-eval :typed-identifier) env))
                 ((setup :variable-initialisation))
                 (return type))
               (const v variable (new variable :uninit none immutable variable-setup initializer env))
               (const multiname multiname (define-singleton-property env name (& namespaces a) (& override-mod a) (& explicit a) read-write v))
               (action<- (multiname :variable-binding 0) multiname)
               (action<- (compile-var :variable-binding 0) v))
             (:narrow (tag virtual final)
               (assert (not no-initializer))
               (const c class (assert-in (nth env 0) class))
               (const v instance-variable (new instance-variable :uninit (in category (tag final)) :uninit :uninit :uninit immutable))
               (const v-overridden instance-variable-opt (assert-in (define-instance-property c cxt name (& namespaces a) (& override-mod a) (& explicit a) v)
                                                                    instance-variable-opt))
               (var enumerable boolean (& enumerable a))
               (when (and (not-in v-overridden (tag none) :narrow-true) (&opt enumerable v-overridden))
                 (<- enumerable true))
               (&const= enumerable v enumerable)
               (action<- (overridden-var :variable-binding 0) v-overridden)
               (action<- (compile-var :variable-binding 0) v))))))
        
        ((setup)
         (const env environment (compile-env :variable-binding 0))
         (const v (union variable dynamic-var instance-variable) (compile-var :variable-binding 0))
         (case v
           (:narrow variable
             (setup-variable v)
             (when (not (& immutable v))
               (const default-value object-opt (& default-value (&opt type v)))
               (rwhen (in default-value (tag none) :narrow-false)
                 (throw-error -uninitialized-error "Cannot declare a mutable variable of type " (:character-literal "Never")))
               (&= value v default-value)))
           (:select dynamic-var
             ((setup :variable-initialisation)))
           (:narrow instance-variable
             (var t class-opt ((setup-and-eval :typed-identifier) env))
             (when (in t (tag none))
               (const overridden-var instance-variable-opt (overridden-var :variable-binding 0))
               (if (not-in overridden-var (tag none) :narrow-true)
                 (<- t (&opt type overridden-var))
                 (<- t -object)))
             (quiet-assert (not-in t (tag none) :narrow-true))
             (&const= type v t)
             ((setup :variable-initialisation))
             (const initializer initializer-opt (initializer :variable-initialisation))
             (var default-value object-opt none)
             (cond
              ((not-in initializer (tag none) :narrow-true)
               (<- default-value (initializer env compile)))
              ((not (& immutable v))
               (<- default-value (& default-value t))
               (rwhen (in default-value (tag none))
                 (throw-error -uninitialized-error "Cannot declare a mutable instance variable of type " (:character-literal "Never")))))
             (&const= default-value v default-value))))
        
        ((eval env)
         (case (compile-var :variable-binding 0)
           (:select variable
             (const inner-frame non-with-frame (assert-not-in (nth env 0) with-frame))
             (const properties (list-set singleton-property) (map (& local-bindings inner-frame) b (& content b) (set-in (& qname b) (multiname :variable-binding 0))))
             (note "The " (:local properties) " set consists of exactly one " (:type variable) " element because " (:local inner-frame)
                   " was constructed with that " (:type variable) " inside " (:action validate) ".")
             (const v variable (assert-in (unique-elt-of properties) variable))
             (const initializer (union initializer (tag none busy)) (& initializer v))
             (case initializer
               (:select (tag none))
               (:select (tag busy) (throw-error -reference-error))
               (:narrow initializer
                 (&= initializer v busy)
                 (const value object (initializer (&opt initializer-env v) run))
                 (exec (write-variable v value true)))))
           (:select dynamic-var
             (const initializer initializer-opt (initializer :variable-initialisation))
             (when (not-in initializer (tag none) :narrow-true)
               (const value object (initializer env run))
               (lexical-write env (multiname :variable-binding 0) value false run)))
           (:select instance-variable)))
        
        ((write-binding env new-value)
         (case (assert-not-in (compile-var :variable-binding 0) instance-variable)
           (:select variable
             (const inner-frame non-with-frame (assert-not-in (nth env 0) with-frame))
             (const properties (list-set singleton-property) (map (& local-bindings inner-frame) b (& content b) (set-in (& qname b) (multiname :variable-binding 0))))
             (note "The " (:local properties) " set consists of exactly one " (:type variable) " element because " (:local inner-frame)
                   " was constructed with that " (:type variable) " inside " (:action validate) ".")
             (const v variable (assert-in (unique-elt-of properties) variable))
             (exec (write-variable v new-value false)))
           (:select dynamic-var
             (lexical-write env (multiname :variable-binding 0) new-value false run))))))
    
    
    (rule (:variable-initialisation :beta) ((validate (-> (context environment) void)) (setup (-> () void))
                                            (initializer initializer-opt))
      (production (:variable-initialisation :beta) () variable-initialisation-none
        ((validate cxt env) :forward)
        ((setup) :forward)
        (initializer none))
      (production (:variable-initialisation :beta) (= (:variable-initializer :beta)) variable-initialisation-variable-initializer
        ((validate cxt env) :forward)
        ((setup) :forward)
        (initializer (eval :variable-initializer))))
    
    (rule (:variable-initializer :beta) ((validate (-> (context environment) void)) (setup (-> () void))
                                         (eval (-> (environment phase) object)))
      (production (:variable-initializer :beta) ((:assignment-expression :beta)) variable-initializer-assignment-expression
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase)
         (return (read-reference ((eval :assignment-expression) env phase) phase))))
      (production (:variable-initializer :beta) (:attribute-combination) variable-initializer-attribute-combination
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env phase) (return ((eval :attribute-combination) env phase)))))
    
    
    (rule (:typed-identifier :beta) ((name string) (plain boolean)
                                     (validate (-> (context environment) void))
                                     (setup-and-eval (-> (environment) class-opt)))
      (production (:typed-identifier :beta) (:identifier) typed-identifier-identifier
        (name (name :identifier))
        (plain true)
        ((validate (cxt :unused) (env :unused)))
        ((setup-and-eval (env :unused)) (return none)))
      (production (:typed-identifier :beta) (:identifier \: (:type-expression :beta)) typed-identifier-identifier-and-type
        (name (name :identifier))
        (plain false)
        ((validate cxt env) ((validate :type-expression) cxt env))
        ((setup-and-eval env) (return ((setup-and-eval :type-expression) env)))))
    ;(production (:typed-identifier :beta) ((:type-expression :beta) :identifier) typed-identifier-type-and-identifier)
    (%print-actions ("Validation" compile-env compile-var overridden-var multiname name plain immutable validate)
                    ("Setup" setup)
                    ("Evaluation" setup-and-eval eval write-binding initializer))
    
    
    (%heading 2 "Simple Variable Definition")
    (%text :syntax "A " (:grammar-symbol :simple-variable-definition) " represents the subset of " (:grammar-symbol :variable-definition)
           " expansions that may be used when the variable definition is used as a " (:grammar-symbol (:substatement :omega))
           " instead of a " (:grammar-symbol (:directive :omega_2)) " in non-strict mode. "
           "In strict mode variable definitions may not be used as substatements.")
    (rule :simple-variable-definition ((validate (-> (context environment) void)) (setup (-> () void))
                                       (eval (-> (environment object) object)))
      (production :simple-variable-definition (var :untyped-variable-binding-list) simple-variable-definition-definition
        ((validate cxt env)
         (rwhen (or (& strict cxt) (not-in (get-regional-frame env) (union package parameter-frame)))
           (throw-error -syntax-error
             "a variable may not be defined in a substatement except inside a non-strict function or non-strict top-level code; "
             "to fix this error, place the definition inside a block"))
         ((validate :untyped-variable-binding-list) cxt env))
        ((setup) :forward)
        ((eval env d)
         ((eval :untyped-variable-binding-list) env)
         (return d))))
    
    (rule :untyped-variable-binding-list ((validate (-> (context environment) void)) (setup (-> () void))
                                          (eval (-> (environment) void)))
      (production :untyped-variable-binding-list (:untyped-variable-binding) untyped-variable-binding-list-one
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env) :forward))
      (production :untyped-variable-binding-list (:untyped-variable-binding-list \, :untyped-variable-binding) untyped-variable-binding-list-more
        ((validate cxt env) :forward)
        ((setup) :forward)
        ((eval env) :forward)))
    
    (rule :untyped-variable-binding ((validate (-> (context environment) void)) (setup (-> () void))
                                     (eval (-> (environment) void)))
      (production :untyped-variable-binding (:identifier (:variable-initialisation allow-in)) untyped-variable-binding-full
        ((validate cxt env)
         ((validate :variable-initialisation) cxt env)
         (exec (define-hoisted-var env (name :identifier) undefined)))
        ((setup) ((setup :variable-initialisation)))
        ((eval env)
         (const initializer initializer-opt (initializer :variable-initialisation))
         (when (not-in initializer (tag none) :narrow-true)
           (const value object (initializer env run))
           (const qname qualified-name (new qualified-name public (name :identifier)))
           (lexical-write env (list-set qname) value false run)))))
    (%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
    
    
    (%heading 2 "Function Definition")
    (rule :function-definition ((overridden-property (writable-cell instance-property-opt))
                                (validate-static (-> (context environment boolean compound-attribute boolean boolean) void))
                                (validate-instance (-> (context environment class compound-attribute boolean) void))
                                (validate-constructor (-> (context environment class compound-attribute) void))
                                (validate (-> (context environment boolean attribute-opt-not-false) void))
                                (setup (-> () void)))
      (production :function-definition (function :function-name :function-common) function-definition-definition
        ((validate-static cxt env preinst a unchecked hoisted)
         (const name string (name :function-name))
         (const handling handling (handling :function-name))
         (case handling
           (:select (tag normal)
             (var kind static-function-kind)
             (cond
              (unchecked (<- kind unchecked-function))
              ((& prototype a) (<- kind prototype-function))
              (nil (<- kind plain-function)))
             (var f (union simple-instance uninstantiated-function) ((validate-static-function :function-common) cxt env kind))
             (when preinst
               (<- f (instantiate-function (assert-in f uninstantiated-function) env)))
             (cond
              (hoisted
               (exec (define-hoisted-var env name f)))
              (nil
               (const v variable (new variable -function f true none none :uninit))
               (exec (define-singleton-property env name (& namespaces a) (& override-mod a) (& explicit a) read-write v)))))
           (:narrow (tag get set)
             (rwhen (& prototype a)
               (throw-error -attribute-error "a getter or setter cannot have the " (:character-literal "prototype") " attribute"))
             (assert (not (or unchecked hoisted)))
             ((validate :function-common) cxt env plain-function handling)
             (var bound-env environment-opt none)
             (when preinst
               (<- bound-env env))
             (case handling
               (:select (tag get)
                 (const getter getter (new getter (eval-static-get :function-common) bound-env))
                 (exec (define-singleton-property env name (& namespaces a) (& override-mod a) (& explicit a) read getter)))
               (:select (tag set)
                 (const setter setter (new setter (eval-static-set :function-common) bound-env))
                 (exec (define-singleton-property env name (& namespaces a) (& override-mod a) (& explicit a) write setter))))))
         (action<- (overridden-property :function-definition 0) none))
        
        ((validate-instance cxt env c a final)
         (rwhen (& prototype a)
           (throw-error -attribute-error "an instance method cannot have the " (:character-literal "prototype") " attribute"))
         (const handling handling (handling :function-name))
         ((validate :function-common) cxt env instance-function handling)
         (const signature parameter-frame (compile-frame :function-common))
         (var m instance-property)
         (case handling
           (:select (tag normal)
             (<- m (new instance-method :uninit final :uninit signature (signature-length signature) (eval-instance-call :function-common))))
           (:select (tag get)
             (<- m (new instance-getter :uninit final :uninit signature (eval-instance-get :function-common))))
           (:select (tag set)
             (<- m (new instance-setter :uninit final :uninit signature (eval-instance-set :function-common)))))
         (const m-overridden instance-property-opt (define-instance-property c cxt (name :function-name) (& namespaces a) (& override-mod a) (& explicit a) m))
         (var enumerable boolean (& enumerable a))
         (when (and (not-in m-overridden (tag none) :narrow-true) (&opt enumerable m-overridden))
           (<- enumerable true))
         (&const= enumerable m enumerable)
         (action<- (overridden-property :function-definition 0) m-overridden))
        
        ((validate-constructor cxt env c a)
         (rwhen (& prototype a)
           (throw-error -attribute-error "a class constructor cannot have the " (:character-literal "prototype") " attribute"))
         (rwhen (in (handling :function-name) (tag get set))
           (throw-error -syntax-error "a class constructor cannot be a getter or a setter"))
         ((validate :function-common) cxt env constructor-function normal)
         (rwhen (not-in (& init c) (tag none))
           (throw-error -definition-error "duplicate constructor definition"))
         (&= init c (eval-instance-init :function-common))
         (action<- (overridden-property :function-definition 0) none))
        
        ((validate cxt env preinst attr)
         (const a compound-attribute (to-compound-attribute attr))
         (rwhen (& dynamic a)
           (throw-error -attribute-error "a function cannot have the " (:character-literal "dynamic") " attribute"))
         (const frame frame (nth env 0))
         (cond
          ((in frame class :narrow-true)
           (assert preinst)
           (case (& category a)
             (:select (tag static)
               ((validate-static :function-definition 0) cxt env preinst a false false))
             (:select (tag none)
               (if (= (name :function-name) (& name frame) string)
                 ((validate-constructor :function-definition 0) cxt env frame a)
                 ((validate-instance :function-definition 0) cxt env frame a false)))
             (:select (tag virtual)
               ((validate-instance :function-definition 0) cxt env frame a false))
             (:select (tag final)
               ((validate-instance :function-definition 0) cxt env frame a true))))
          (nil
           (rwhen (not-in (& category a) (tag none))
             (throw-error -attribute-error
               "non-class functions cannot have a " (:character-literal "static") ", " (:character-literal "virtual") ", or "
               (:character-literal "final") " attribute"))
           (const unchecked boolean (and (not (& strict cxt)) (in (handling :function-name) (tag normal)) (plain :function-common)))
           (const hoisted boolean (and unchecked
                                       (in attr (tag none))
                                       (or (in frame package) (and (in frame local-frame) (in (nth env 1) parameter-frame)))))
           ((validate-static :function-definition 0) cxt env preinst a unchecked hoisted))))
        
        ((setup)
         (const overridden-property instance-property-opt (overridden-property :function-definition 0))
         (case overridden-property
           (:select (tag none)
             ((setup :function-common)))
           (:narrow (union instance-method instance-getter instance-setter)
             ((setup-override :function-common) (&opt signature overridden-property)))
           (:narrow instance-variable
             (var overridden-signature parameter-frame)
             (case (handling :function-name)
               (:select (tag normal)
                 (bottom "This cannot happen because " (:action validate-instance) " already ensured that a function cannot override an instance variable."))
               (:select (tag get)
                 (<- overridden-signature (new parameter-frame (list-set-of local-binding) instance-function get false false none
                                               (vector-of parameter) none (&opt type overridden-property))))
               (:select (tag set)
                 (const v variable (new variable (&opt type overridden-property) none false none none :uninit))
                 (const parameters (vector parameter) (vector (new parameter v none)))
                 (<- overridden-signature (new parameter-frame (list-set-of local-binding) instance-function set false false none
                                               parameters none -void))))
             ((setup-override :function-common) overridden-signature))))))
    
    
    (rule :function-name ((handling handling) (name string))
      (production :function-name (:identifier) function-name-function
        (handling normal)
        (name (name :identifier)))
      (production :function-name (get :no-line-break :identifier) function-name-getter
        (handling get)
        (name (name :identifier)))
      (production :function-name (set :no-line-break :identifier) function-name-setter
        (handling set)
        (name (name :identifier))))
    
    
    (rule :function-common ((plain boolean)
                            (compile-env (writable-cell environment))
                            (compile-frame (writable-cell parameter-frame))
                            (validate (-> (context environment function-kind handling) void))
                            (setup (-> () void))
                            (setup-override (-> (parameter-frame) void))
                            (eval-static-call (-> (object simple-instance (vector object) phase) object))
                            (eval-static-get (-> (environment phase) object))
                            (eval-static-set (-> (object environment phase) void))
                            (eval-instance-call (-> (object (vector object) phase) object))
                            (eval-instance-get (-> (object phase) object))
                            (eval-instance-set (-> (object object phase) void))
                            (eval-instance-init (-> (simple-instance (vector object) (tag run)) void))
                            (eval-prototype-construct (-> (simple-instance (vector object) phase) object))
                            (validate-static-function (-> (context environment static-function-kind) uninstantiated-function)))
      (production :function-common (\( :parameters \) :result :block) function-common-signatures-and-block
        (plain (and (plain :parameters) (plain :result)))
        ((validate cxt env kind handling)
         (const local-cxt context (new context (& strict cxt) (& open-namespaces cxt)))
         (const superconstructor-called boolean (not-in kind (tag constructor-function)))
         (const compile-frame parameter-frame (new parameter-frame (list-set-of local-binding) kind handling false superconstructor-called none
                                                   (vector-of parameter) none :uninit))
         (const compile-env environment (cons compile-frame env))
         (action<- (compile-frame :function-common 0) compile-frame)
         (action<- (compile-env :function-common 0) compile-env)
         (when (in kind (tag unchecked-function))
           (exec (define-hoisted-var compile-env "arguments" undefined)))
         ((validate :parameters) local-cxt compile-env compile-frame)
         ((validate :result) local-cxt compile-env)
         ((validate :block) local-cxt compile-env (new jump-targets (list-set-of label) (list-set-of label)) false))
        
        ((setup)
         (const compile-env environment (compile-env :function-common 0))
         (const compile-frame parameter-frame (compile-frame :function-common 0))
         ((setup :parameters) compile-env compile-frame)
         (check-accessor-parameters compile-frame)
         ((setup :result) compile-env compile-frame)
         ((setup :block)))
        
        ((setup-override overridden-signature)
         (const compile-env environment (compile-env :function-common 0))
         (const compile-frame parameter-frame (compile-frame :function-common 0))
         ((setup-override :parameters) compile-env compile-frame overridden-signature)
         (check-accessor-parameters compile-frame)
         ((setup-override :result) compile-env compile-frame overridden-signature)
         ((setup :block)))
        
        ((eval-static-call this f args phase)
         (note "The check that " (:expr boolean (not-in phase (tag compile))) " also ensures that " (:action setup) " has been called.")
         (rwhen (in phase (tag compile) :narrow-false)
           (throw-error -constant-error "a constant expression cannot call user-defined functions"))
         (const runtime-env environment (assert-not-in (& env f) (tag none)))
         (var runtime-this object-opt none)
         (const compile-frame parameter-frame (compile-frame :function-common 0))
         (when (in (& kind compile-frame) (tag unchecked-function prototype-function))
           (if (in this primitive-object)
             (<- runtime-this (get-package-frame runtime-env))
             (<- runtime-this this)))
         (const runtime-frame parameter-frame (instantiate-parameter-frame compile-frame runtime-env runtime-this))
         (assign-arguments runtime-frame f args phase)
         (var result object)
         (catch ((exec ((eval :block) (cons runtime-frame runtime-env) undefined))
                 (<- result undefined))
           (x) (if (in x return :narrow-true)
                 (<- result (& value x))
                 (throw x)))
         (return (coerce result (&opt return-type runtime-frame))))
        
        ((eval-static-get runtime-env phase)
         (note "The check that " (:expr boolean (not-in phase (tag compile))) " also ensures that " (:action setup) " has been called.")
         (rwhen (in phase (tag compile) :narrow-false)
           (throw-error -constant-error "a constant expression cannot call user-defined getters"))
         (const compile-frame parameter-frame (compile-frame :function-common 0))
         (const runtime-frame parameter-frame (instantiate-parameter-frame compile-frame runtime-env none))
         (assign-arguments runtime-frame none (vector-of object) phase)
         (var result object)
         (catch ((exec ((eval :block) (cons runtime-frame runtime-env) undefined))
                 (throw-error -syntax-error "a getter must return a value and may not return by falling off the end of its code"))
           (x) (if (in x return :narrow-true)
                 (<- result (& value x))
                 (throw x)))
         (return (coerce result (&opt return-type runtime-frame))))
        
        ((eval-static-set new-value runtime-env phase)
         (note "The check that " (:expr boolean (not-in phase (tag compile))) " also ensures that " (:action setup) " has been called.")
         (rwhen (in phase (tag compile) :narrow-false)
           (throw-error -constant-error "a constant expression cannot call setters"))
         (const compile-frame parameter-frame (compile-frame :function-common 0))
         (const runtime-frame parameter-frame (instantiate-parameter-frame compile-frame runtime-env none))
         (assign-arguments runtime-frame none (vector new-value) phase)
         (catch ((exec ((eval :block) (cons runtime-frame runtime-env) undefined)))
           (x) (rwhen (not-in x return)
                 (throw x))))
        
        ((eval-instance-call this args phase)
         (note "The check that " (:expr boolean (not-in phase (tag compile))) " also ensures that " (:action setup) " has been called.")
         (rwhen (in phase (tag compile) :narrow-false)
           (throw-error -constant-error "a constant expression cannot call user-defined functions"))
         (note "Class frames are always preinstantiated, so the run environment is the same as compile environment.")
         (const env environment (compile-env :function-common 0))
         (const compile-frame parameter-frame (compile-frame :function-common 0))
         (const runtime-frame parameter-frame (instantiate-parameter-frame compile-frame env this))
         (assign-arguments runtime-frame none args phase)
         (var result object)
         (catch ((exec ((eval :block) (cons runtime-frame env) undefined))
                 (<- result undefined))
           (x) (if (in x return :narrow-true)
                 (<- result (& value x))
                 (throw x)))
         (return (coerce result (&opt return-type runtime-frame))))
        
        ((eval-instance-get this phase)
         (note "The check that " (:expr boolean (not-in phase (tag compile))) " also ensures that " (:action setup) " has been called.")
         (rwhen (in phase (tag compile) :narrow-false)
           (throw-error -constant-error "a constant expression cannot call user-defined getters"))
         (note "Class frames are always preinstantiated, so the run environment is the same as compile environment.")
         (const env environment (compile-env :function-common 0))
         (const compile-frame parameter-frame (compile-frame :function-common 0))
         (const runtime-frame parameter-frame (instantiate-parameter-frame compile-frame env this))
         (assign-arguments runtime-frame none (vector-of object) phase)
         (var result object)
         (catch ((exec ((eval :block) (cons runtime-frame env) undefined))
                 (throw-error -syntax-error "a getter must return a value and may not return by falling off the end of its code"))
           (x) (if (in x return :narrow-true)
                 (<- result (& value x))
                 (throw x)))
         (return (coerce result (&opt return-type runtime-frame))))
        
        ((eval-instance-set this new-value phase)
         (note "The check that " (:expr boolean (not-in phase (tag compile))) " also ensures that " (:action setup) " has been called.")
         (rwhen (in phase (tag compile) :narrow-false)
           (throw-error -constant-error "a constant expression cannot call setters"))
         (note "Class frames are always preinstantiated, so the run environment is the same as compile environment.")
         (const env environment (compile-env :function-common 0))
         (const compile-frame parameter-frame (compile-frame :function-common 0))
         (const runtime-frame parameter-frame (instantiate-parameter-frame compile-frame env this))
         (assign-arguments runtime-frame none (vector new-value) phase)
         (catch ((exec ((eval :block) (cons runtime-frame env) undefined)))
           (x) (rwhen (not-in x return)
                 (throw x))))
        
        ((eval-instance-init this args phase)
         (note "Class frames are always preinstantiated, so the run environment is the same as compile environment.")
         (const env environment (compile-env :function-common 0))
         (const compile-frame parameter-frame (compile-frame :function-common 0))
         (const runtime-frame parameter-frame (instantiate-parameter-frame compile-frame env this))
         (assign-arguments runtime-frame none args phase)
         (when (not (& calls-superconstructor runtime-frame))
           (const c class (assert-not-in (get-enclosing-class env) (tag none)))
           (call-init this (& super c) (vector-of object) run)
           (&= superconstructor-called runtime-frame true))
         (catch ((exec ((eval :block) (cons runtime-frame env) undefined)))
           (x) (rwhen (not-in x return)
                 (throw x)))
         (rwhen (not (& superconstructor-called runtime-frame))
           (throw-error -uninitialized-error "the superconstructor must be called before returning normally from a constructor")))
        
        ((eval-prototype-construct f args phase)
         (note "The check that " (:expr boolean (not-in phase (tag compile))) " also ensures that " (:action setup) " has been called.")
         (rwhen (in phase (tag compile) :narrow-false)
           (throw-error -constant-error "a constant expression cannot call user-defined prototype constructors"))
         (const runtime-env environment (assert-not-in (& env f) (tag none)))
         (var archetype object (dot-read f (list-set (new qualified-name public "prototype")) phase))
         (cond
          ((in archetype (tag null undefined)) (<- archetype -object-prototype))
          ((/= (object-type archetype) -object class) (throw-error -type-error "bad " (:character-literal "prototype") " value")))
         (var o object (create-simple-instance -object archetype none none none))
         (const compile-frame parameter-frame (compile-frame :function-common 0))
         (const runtime-frame parameter-frame (instantiate-parameter-frame compile-frame runtime-env o))
         (assign-arguments runtime-frame f args phase)
         (var result object)
         (catch ((exec ((eval :block) (cons runtime-frame runtime-env) undefined))
                 (<- result undefined))
           (x) (if (in x return :narrow-true)
                 (<- result (& value x))
                 (throw x)))
         (const coerced-result object (coerce result (&opt return-type runtime-frame)))
         (if (in coerced-result primitive-object)
           (return o)
           (return coerced-result)))
        
        ((validate-static-function cxt env kind)
         ((validate :function-common 0) cxt env kind normal)
         (const length integer (parameter-count :parameters))
         (case kind
           (:select (tag plain-function)
             (return (new uninstantiated-function -function length (eval-static-call :function-common 0) none (list-set-of simple-instance))))
           (:select (tag unchecked-function prototype-function)
             (return (new uninstantiated-function -prototype-function length (eval-static-call :function-common 0) (eval-prototype-construct :function-common 0)
                          (list-set-of simple-instance))))))))

    (%print-actions ("Validation" overridden-property handling name plain compile-env compile-frame
                     validate validate-static validate-instance validate-constructor validate-static-function)
                    ("Setup" setup setup-override)
                    ("Evaluation" eval-static-call eval-static-get eval-static-set eval-instance-call eval-instance-get eval-instance-set eval-instance-init eval-prototype-construct))
    
    
    (define (check-accessor-parameters (frame parameter-frame)) void
      (const parameters (vector parameter) (&opt parameters frame))
      (const rest variable-opt (&opt rest frame))
      (case (& handling frame)
        (:select (tag normal))
        (:select (tag get)
          (rwhen (or (nonempty parameters) (not-in rest (tag none)))
            (throw-error -syntax-error "a getter cannot take any parameters")))
        (:select (tag set)
          (rwhen (or (/= (length parameters) 1) (not-in rest (tag none)))
            (throw-error -syntax-error "a setter must take exactly one parameter"))
          (rwhen (not-in (& default (nth parameters 0)) (tag none))
            (throw-error -syntax-error "a setter" :apostrophe "s parameter cannot be optional")))))
    
    
    (define (assign-arguments (runtime-frame parameter-frame) (f (union simple-instance (tag none))) (args (vector object)) (phase (tag run))) void
      (// "This procedure performs a number of checks on the arguments, including checking their count, names, and values. "
          "Although this procedure performs these checks in a specific order for expository purposes, an implementation may perform these checks in a different "
          "order, which could have the effect of reporting a different error if there are multiple errors. "
          "For example, if a function only allows between 2 and 4 arguments, the first of which must be a " (:character-literal "Number")
          " and is passed five arguments the first of which is a " (:character-literal "String") ", then the implementation may throw an exception either about "
          "the argument count mismatch or about the type coercion error in the first argument.")
      (var arguments-object object-opt none)
      (when (in (& kind runtime-frame) (tag unchecked-function))
        (<- arguments-object (construct -array (vector-of object) phase))
        (create-dynamic-property (assert-in arguments-object simple-instance) (new qualified-name public "callee") false false (assert-not-in f (tag none)))
        (write-array-private-length (assert-not-in arguments-object (tag none)) (length args) phase))
      (var rest-object object-opt none)
      (const rest (union variable (tag none)) (&opt rest runtime-frame))
      (when (not-in rest (tag none) :narrow-true)
        (<- rest-object (construct -array (vector-of object) phase)))
      (const parameters (vector parameter) (&opt parameters runtime-frame))
      (var i integer 0)
      (var j integer 0)
      (for-each args arg
        (cond
         ((< i (length parameters))
          (const parameter parameter (nth parameters i))
          (var default object-opt (& default parameter))
          (var arg-or-default object arg)
          (when (and (in arg-or-default (tag undefined)) (not-in default (tag none) :narrow-true))
            (<- arg-or-default default))
          (const v (union dynamic-var variable) (& var parameter))
          (write-singleton-property v arg-or-default phase)
          (when (not-in arguments-object (tag none) :narrow-true)
            (note "Create an alias of " (:local v) " as the " (:local i) "th entry of the " (:character-literal "arguments") " object.")
            (assert (in v dynamic-var))
            (const qname qualified-name (object-to-qualified-name (real-to-float64 i) phase))
            (&= local-bindings (assert-in arguments-object simple-instance) (set+ (& local-bindings (assert-in arguments-object simple-instance))
                                                                                  (list-set (new local-binding qname read-write false false v))))))
         ((not-in rest-object (tag none) :narrow-true)
          (rwhen (>= j array-limit)
            (throw-error -range-error))
          (index-write rest-object j arg phase)
          (assert (in arguments-object (tag none))
            (:assertion) " because a function can't have both a rest parameter and an " (:character-literal "arguments") " object.")
          (<- j (+ j 1)))
         ((not-in arguments-object (tag none) :narrow-true)
          (index-write arguments-object i arg phase))
         (nil (throw-error -argument-error
                "more arguments than parameters were supplied, and the called function does not have a " (:character-literal "...") " parameter and is not unchecked.")))
        (<- i (+ i 1)))
      (while (< i (length parameters))
        (const parameter parameter (nth parameters i))
        (var default object-opt (& default parameter))
        (when (in default (tag none))
          (if (not-in arguments-object (tag none))
            (<- default undefined)
            (throw-error -argument-error
              "fewer arguments than parameters were supplied, and the called function does not supply default values for the missing parameters and is not unchecked.")))
        (quiet-assert (not-in default (tag none) :narrow-true))
        (write-singleton-property (& var parameter) default phase)
        (<- i (+ i 1))))
    
    
    (define (signature-length (signature parameter-frame)) integer
      (return (length (&opt parameters signature))))
    
    
    (rule :parameters ((plain boolean) (parameter-count integer)
                       (validate (-> (context environment parameter-frame) void))
                       (setup (-> (environment parameter-frame) void))
                       (setup-override (-> (environment parameter-frame parameter-frame) void)))
      (production :parameters () parameters-none
        (plain true)
        (parameter-count 0)
        ((validate cxt env compile-frame) :forward)
        ((setup compile-env compile-frame) :forward)
        ((setup-override (compile-env :unused) (compile-frame :unused) overridden-signature)
         (rwhen (or (nonempty (&opt parameters overridden-signature))
                    (not-in (&opt rest overridden-signature) (tag none)))
           (throw-error -definition-error "mismatch with the overridden method" :apostrophe "s signature"))))
      (production :parameters (:nonempty-parameters) parameters-nonempty
        (plain (plain :nonempty-parameters))
        (parameter-count (parameter-count :nonempty-parameters))
        ((validate cxt env compile-frame) :forward)
        ((setup compile-env compile-frame) :forward)
        ((setup-override compile-env compile-frame overridden-signature)
         ((setup-override :nonempty-parameters) compile-env compile-frame overridden-signature (&opt parameters overridden-signature)))))
    
    
    (rule :nonempty-parameters ((plain boolean) (parameter-count integer)
                                (validate (-> (context environment parameter-frame) void))
                                (setup (-> (environment parameter-frame) void))
                                (setup-override (-> (environment parameter-frame parameter-frame (vector parameter)) void)))
      (production :nonempty-parameters (:parameter-init) nonempty-parameters-parameter-init
        (plain (plain :parameter-init))
        (parameter-count 1)
        ((validate cxt env compile-frame) :forward)
        ((setup compile-env compile-frame)
         ((setup :parameter-init) compile-env compile-frame))
        ((setup-override compile-env compile-frame overridden-signature overridden-parameters)
         (rwhen (empty overridden-parameters)
           (throw-error -definition-error "mismatch with the overridden method" :apostrophe "s signature"))
         ((setup-override :parameter-init) compile-env compile-frame (nth overridden-parameters 0))
         (rwhen (or (/= (length overridden-parameters) 1)
                    (not-in (&opt rest overridden-signature) (tag none)))
           (throw-error -definition-error "mismatch with the overridden method" :apostrophe "s signature"))))
      (production :nonempty-parameters (:parameter-init \, :nonempty-parameters) nonempty-parameters-parameter-init-and-more
        (plain (and (plain :parameter-init) (plain :nonempty-parameters)))
        (parameter-count (+ 1 (parameter-count :nonempty-parameters)))
        ((validate cxt env compile-frame) :forward)
        ((setup compile-env compile-frame)
         ((setup :parameter-init) compile-env compile-frame)
         ((setup :nonempty-parameters) compile-env compile-frame))
        ((setup-override compile-env compile-frame overridden-signature overridden-parameters)
         (rwhen (empty overridden-parameters)
           (throw-error -definition-error "mismatch with the overridden method" :apostrophe "s signature"))
         ((setup-override :parameter-init) compile-env compile-frame (nth overridden-parameters 0))
         ((setup-override :nonempty-parameters) compile-env compile-frame overridden-signature (subseq overridden-parameters 1))))
      (production :nonempty-parameters (:rest-parameter) nonempty-parameters-rest-parameter
        (plain false)
        (parameter-count 0)
        ((validate cxt env compile-frame) :forward)
        ((setup (compile-env :unused) (compile-frame :unused)))
        ((setup-override (compile-env :unused) (compile-frame :unused) overridden-signature overridden-parameters)
         (rwhen (nonempty overridden-parameters)
           (throw-error -definition-error "mismatch with the overridden method" :apostrophe "s signature"))
         (const overridden-rest (union variable (tag none)) (&opt rest overridden-signature))
         (rwhen (or (in overridden-rest (tag none) :narrow-false) (/= (&opt type overridden-rest) -array class))
           (throw-error -definition-error "mismatch with the overridden method" :apostrophe "s signature")))))
    
    
    (rule :parameter ((name string)
                      (plain boolean)
                      (compile-var (writable-cell (union dynamic-var variable)))
                      (validate (-> (context environment (union parameter-frame local-frame)) void))
                      (setup (-> (environment (union parameter-frame local-frame) object-opt) void))
                      (setup-override (-> (environment parameter-frame object-opt parameter) void)))
      (production :parameter (:parameter-attributes (:typed-identifier allow-in)) parameter-attributes-and-typed-identifier
        (name (name :typed-identifier))
        (plain (and (plain :typed-identifier) (not (has-const :parameter-attributes))))
        ((validate cxt env compile-frame)
         ((validate :typed-identifier) cxt env)
         (const immutable boolean (has-const :parameter-attributes))
         (const name string (name :typed-identifier))
         (var v (union dynamic-var variable))
         (cond
          ((and (in compile-frame parameter-frame :narrow-true) (in (& kind compile-frame) (tag unchecked-function)))
           (assert (not immutable))
           (<- v (define-hoisted-var env name undefined)))
          (nil
           (<- v (new variable :uninit none immutable none none :uninit))
           (exec (define-singleton-property env name (list-set public) none false read-write v))))
         (action<- (compile-var :parameter 0) v))
        ((setup compile-env compile-frame default)
         (rwhen (and (in compile-frame parameter-frame :narrow-true)
                     (in default (tag none))
                     (some (&opt parameters compile-frame) p2 (not-in (& default p2) (tag none))))
           (throw-error -syntax-error "a required parameter cannot follow an optional one"))
         (const v (union dynamic-var variable) (compile-var :parameter 0))
         (case v
           (:select dynamic-var)
           (:narrow variable
             (var type class-opt ((setup-and-eval :typed-identifier) compile-env))
             (when (in type (tag none))
               (<- type -object))
             (quiet-assert (not-in type (tag none) :narrow-true))
             (&const= type v type)))
         (when (in compile-frame parameter-frame :narrow-true)
           (const p parameter (new parameter v default))
           (&= parameters compile-frame (append (&opt parameters compile-frame) (vector p)))))
        ((setup-override compile-env compile-frame default overridden-parameter)
         (var new-default object-opt default)
         (when (in new-default (tag none))
           (<- new-default (& default overridden-parameter)))
         (rwhen (and (in default (tag none)) (some (&opt parameters compile-frame) p2 (not-in (& default p2) (tag none))))
           (throw-error -syntax-error "a required parameter cannot follow an optional one"))
         (const v (union dynamic-var variable) (compile-var :parameter 0))
         (assert (not-in v dynamic-var :narrow-true))
         (var type class-opt ((setup-and-eval :typed-identifier) compile-env))
         (when (in type (tag none))
           (<- type -object))
         (quiet-assert (not-in type (tag none) :narrow-true))
         (rwhen (/= type (&opt type (assert-not-in (& var overridden-parameter) dynamic-var)) class)
           (throw-error -definition-error "mismatch with the overridden method" :apostrophe "s signature"))
         (&const= type v type)
         (const p parameter (new parameter v new-default))
         (&= parameters compile-frame (append (&opt parameters compile-frame) (vector p))))))
    
    
    (rule :parameter-attributes ((has-const boolean))
      (production :parameter-attributes () parameter-parameter-none
        (has-const false))
      (production :parameter-attributes (const) parameter-parameter-const
        (has-const true)))
    
    
    (rule :parameter-init ((plain boolean)
                           (validate (-> (context environment parameter-frame) void))
                           (setup (-> (environment parameter-frame) void))
                           (setup-override (-> (environment parameter-frame parameter) void)))
      (production :parameter-init (:parameter) parameter-init-parameter
        (plain (plain :parameter))
        ((validate cxt env compile-frame)
         ((validate :parameter) cxt env compile-frame))
        ((setup compile-env compile-frame)
         ((setup :parameter) compile-env compile-frame none))
        ((setup-override compile-env compile-frame overridden-parameter)
         ((setup-override :parameter) compile-env compile-frame none overridden-parameter)))
      (production :parameter-init (:parameter = (:assignment-expression allow-in)) parameter-init-initializer
        (plain false)
        ((validate cxt env compile-frame)
         ((validate :parameter) cxt env compile-frame)
         ((validate :assignment-expression) cxt env))
        ((setup compile-env compile-frame)
         ((setup :assignment-expression))
         (const default object (read-reference ((eval :assignment-expression) compile-env compile) compile))
         ((setup :parameter) compile-env compile-frame default))
        ((setup-override compile-env compile-frame overridden-parameter)
         ((setup :assignment-expression))
         (const default object (read-reference ((eval :assignment-expression) compile-env compile) compile))
         ((setup-override :parameter) compile-env compile-frame default overridden-parameter))))
    
    
    (rule :rest-parameter ((validate (-> (context environment parameter-frame) void)))
      (production :rest-parameter (\.\.\.) rest-parameter-none
        ((validate (cxt :unused) (env :unused) compile-frame)
         (assert (not-in (& kind compile-frame) (tag unchecked-function)))
         (const v variable (new variable -array none true none none :uninit))
         (&= rest compile-frame v)))
      (production :rest-parameter (\.\.\. :parameter-attributes :identifier) rest-parameter-parameter
        ((validate (cxt :unused) env compile-frame)
         (assert (not-in (& kind compile-frame) (tag unchecked-function)))
         (const v variable (new variable -array none (has-const :parameter-attributes) none none :uninit))
         (&= rest compile-frame v)
         (const name string (name :identifier))
         (exec (define-singleton-property env name (list-set public) none false read-write v)))))
    
    
    (rule :result ((plain boolean)
                   (validate (-> (context environment) void))
                   (setup (-> (environment parameter-frame) void))
                   (setup-override (-> (environment parameter-frame parameter-frame) void)))
      (production :result () result-none
        (plain true)
        ((validate cxt env) :forward)
        ((setup (compile-env :unused) compile-frame)
         (var default-return-type class -object)
         (when (cannot-return-value compile-frame)
           (<- default-return-type -void))
         (&const= return-type compile-frame default-return-type))
        ((setup-override (compile-env :unused) compile-frame overridden-signature)
         (&const= return-type compile-frame (&opt return-type overridden-signature))))
      (production :result (\: (:type-expression allow-in)) result-colon-and-type-expression
        (plain false)
        ((validate cxt env) :forward)
        ((setup compile-env compile-frame)
         (rwhen (cannot-return-value compile-frame)
           (throw-error -syntax-error "a setter or constructor cannot define a return type"))
         (&const= return-type compile-frame ((setup-and-eval :type-expression) compile-env)))
        ((setup-override compile-env compile-frame overridden-signature)
         (const t class ((setup-and-eval :type-expression) compile-env))
         (rwhen (/= (&opt return-type overridden-signature) t class)
           (throw-error -definition-error "mismatch with the overridden method" :apostrophe "s signature"))
         (&const= return-type compile-frame t)))
      ;(production :result ((:- {) (:type-expression allow-in)) result-type-expression)
      )
    (%print-actions ("Validation" name plain has-const parameter-count compile-var validate) ("Setup" setup setup-override))
    
    
    (%heading 2 "Class Definition")
    (rule :class-definition ((class (writable-cell class))
                             (validate (-> (context environment boolean attribute-opt-not-false) void))
                             (setup (-> () void))
                             (eval (-> (environment object) object)))
      (production :class-definition (class :identifier :inheritance :block) class-definition-definition
        ((validate cxt env preinst attr)
         (rwhen (not preinst)
           (throw-error -syntax-error "a class may be defined only in a preinstantiated scope"))
         (const super class ((validate :inheritance) cxt env))
         (rwhen (not (& complete super))
           (throw-error -constant-error "cannot override a class before its definition has been compiled"))
         (rwhen (& final super)
           (throw-error -definition-error "can" :apostrophe "t override a " (:character-literal "final") " class"))
         (var a compound-attribute (to-compound-attribute attr))
         (rwhen (& prototype a)
           (throw-error -attribute-error "a class definition cannot have the " (:character-literal "prototype") " attribute"))
         (var final boolean)
         (case (& category a)
           (:select (tag none) (<- final false))
           (:select (tag static)
             (rwhen (not-in (nth env 0) class)
               (throw-error -attribute-error "non-class property definitions cannot have a " (:character-literal "static") " attribute"))
             (<- final false))
           (:select (tag final) (<- final true))
           (:select (tag virtual) (throw-error -attribute-error "a class definition cannot have the " (:character-literal "virtual") " attribute")))
         (const private-namespace namespace (new namespace "private"))
         (const dynamic boolean (or (& dynamic a) (and (& dynamic super) (/= super -object class))))
         (const c class (new class
                          (list-set-of local-binding) (list-set-of instance-property) super (&opt prototype super) false
                          (name :identifier) "object" private-namespace dynamic final null hint-number
                          (& has-property super) (& bracket-read super) (& bracket-write super) (& bracket-delete super)
                          (& read super) (& write super) (& delete super)
                          (& enumerate super)
                          ordinary-call ordinary-construct none ordinary-is ordinary-coerce))
         (action<- (class :class-definition 0) c)
         (const v variable (new variable -class c true none none :uninit))
         (exec (define-singleton-property env (name :identifier) (& namespaces a) (& override-mod a) (& explicit a) read-write v))
         (const inner-cxt context (new context (& strict cxt) (set+ (& open-namespaces cxt) (list-set private-namespace))))
         ((validate-using-frame :block) inner-cxt env (new jump-targets (list-set-of label) (list-set-of label)) preinst c)
         (when (in (& init c) (tag none))
           (&= init c (& init super)))
         (&= complete c true))
        
        ((setup)
         ((setup :block)))
        
        ((eval env d)
         (const c class (class :class-definition 0))
         (return ((eval-using-frame :block) env c d)))))
    
    
    (rule :inheritance ((validate (-> (context environment) class)))
      (production :inheritance () inheritance-none
        ((validate (cxt :unused) (env :unused)) (return -object)))
      (production :inheritance (extends (:type-expression allow-in)) inheritance-extends
        ((validate cxt env)
         ((validate :type-expression) cxt env)
         (return ((setup-and-eval :type-expression) env))))
      #|(production :inheritance (implements :type-expression-list) inheritance-implements
        ((validate (cxt :unused) (env :unused)) (return -object)))
      (production :inheritance (extends (:type-expression allow-in) implements :type-expression-list) inheritance-extends-implements
        ((validate (cxt :unused) (env :unused)) (return -object)))|#)
    (%print-actions ("Validation" class validate) ("Setup" setup) ("Evaluation" eval))
    
    
    ;(%heading 2 "Interface Definition")
    ;(production (:interface-definition :omega_2) (interface :identifier :extends-list :block) interface-definition-definition)
    ;(production (:interface-definition :omega_2) (interface :identifier (:semicolon :omega_2)) interface-definition-declaration)
    ;***** Clear break and continue inside validate
    
    ;(production :extends-list () extends-list-none)
    ;(production :extends-list (extends :type-expression-list) extends-list-one)
    
    ;(production :type-expression-list ((:type-expression allow-in)) type-expression-list-one)
    ;(production :type-expression-list (:type-expression-list \, (:type-expression allow-in)) type-expression-list-more)
    
    
    (%heading 2 "Namespace Definition")
    (rule :namespace-definition ((validate (-> (context environment boolean attribute-opt-not-false) void)))
      (production :namespace-definition (namespace :identifier) namespace-definition-normal
        ((validate (cxt :unused) env preinst attr)
         (rwhen (not preinst)
           (throw-error -syntax-error "a namespace may be defined only in a preinstantiated scope"))
         (const a compound-attribute (to-compound-attribute attr))
         (rwhen (& dynamic a)
           (throw-error -attribute-error "a namespace definition cannot have the " (:character-literal "dynamic") " attribute"))
         (rwhen (& prototype a)
           (throw-error -attribute-error "a namespace definition cannot have the " (:character-literal "prototype") " attribute"))
         (case (& category a)
           (:select (tag none))
           (:select (tag static)
             (rwhen (not-in (nth env 0) class)
               (throw-error -attribute-error "non-class property definitions cannot have a " (:character-literal "static") " attribute")))
           (:select (tag virtual final)
             (throw-error -attribute-error
               "a namespace definition cannot have the " (:character-literal "virtual") " or " (:character-literal "final") " attribute")))
         (const name string (name :identifier))
         (const ns namespace (new namespace name))
         (const v variable (new variable -namespace ns true none none :uninit))
         (exec (define-singleton-property env name (& namespaces a) (& override-mod a) (& explicit a) read-write v)))))
    (%print-actions ("Validation" validate))
    
    
    (%heading 1 "Programs")
    (rule :program ((process object))
      (production :program (:directives) program-directives
        (process
         (begin
          (const cxt context (new context false (list-set public internal)))
          (const initial-environment environment (vector-of frame (create-global-object)))
          ((validate :directives) cxt initial-environment (new jump-targets (list-set-of label) (list-set-of label)) true none)
          ((setup :directives))
          (return ((eval :directives) initial-environment undefined)))))
      (production :program (:package-definition :program) program-package-and-program
        (process
         (begin
          (process :package-definition)
          (return (process :program))))))
    (%print-actions ("Processing" process))
    
    
    (%heading 2 "Package Definition")
    (rule :package-definition ((process void))
      (production :package-definition (package :package-name-opt :block) package-definition-name-and-block
        (process
         (begin
          (const name string (name :package-name-opt))
          (const cxt context (new context false (list-set public internal)))
          (const global-object package (create-global-object))
          (const pkg-internal namespace (new namespace "internal"))
          (const pkg package (new package
                               (list-set (std-explicit-const-binding (new qualified-name internal "internal") -namespace internal))
                               -object-prototype name busy true pkg-internal))
          (const initial-environment environment (vector-of frame pkg global-object))
          ((validate :block) cxt initial-environment (new jump-targets (list-set-of label) (list-set-of label)) true)
          ((setup :block))
          (function (eval-package) void
            (&= initialize pkg busy)
            (exec ((eval :block) initial-environment undefined))
            (&= initialize pkg none))
          (&= initialize pkg eval-package)
          (/* "Bind " (:local name) " to package " (:local pkg) " in the system" :apostrophe "s list of packages in an implementation-defined manner.")
          (<- package-database (set+ package-database (list-set pkg)))
          (*/)))))
    
    
    (rule :package-name-opt ((name string))
      (production :package-name-opt () package-name-opt-none
        (name (/*/ "" "an implementation-supplied name")))
      (production :package-name-opt (:package-name) package-name-opt-package-name
        (name (name :package-name))))
    
    (rule :package-name ((name string))
      (production :package-name ($string) package-name-string
        (name (/*/ (value $string) (:expr string (value $string)) " processed in an implementation-defined manner")))
      (production :package-name (:package-identifiers) package-name-package-identifiers
        (name (/*/ (nth (names :package-identifiers) 0) (:expr (vector string) (names :package-identifiers)) " processed in an implementation-defined manner"))))
    
    (rule :package-identifiers ((names (vector string)))
      (production :package-identifiers (:identifier) package-identifiers-one
        (names (vector (name :identifier))))
      (production :package-identifiers (:package-identifiers \. :identifier) package-identifiers-more
        (names (append (names :package-identifiers) (vector (name :identifier))))))
    (%print-actions ("Processing" process name names))
    
    (defvar package-database (list-set package) (list-set-of package))
    
    
    (%heading (1 :semantics) "Predefined Identifiers")
    (define (create-global-object) package
      (return
       (new package
         (%list-set
          (std-explicit-const-binding (new qualified-name internal "internal") -namespace internal)
          
          (std-const-binding (new qualified-name public "explicit") -attribute global_explicit)
          (std-const-binding (new qualified-name public "enumerable") -attribute global_enumerable)
          (std-const-binding (new qualified-name public "dynamic") -attribute global_dynamic)
          (std-const-binding (new qualified-name public "static") -attribute global_static)
          (std-const-binding (new qualified-name public "virtual") -attribute global_virtual)
          (std-const-binding (new qualified-name public "final") -attribute global_final)
          (std-const-binding (new qualified-name public "prototype") -attribute global_prototype)
          (std-const-binding (new qualified-name public "unused") -attribute global_unused)
          (std-function (new qualified-name public "override") global_override 1)
          
          (std-const-binding (new qualified-name public "NaN") -number nan64)
          (std-const-binding (new qualified-name public "Infinity") -number +infinity64)
          (std-const-binding (new qualified-name public "fNaN") float nan32)
          (std-const-binding (new qualified-name public "fInfinity") float +infinity32)
          (std-const-binding (new qualified-name public "undefined") -void undefined)
          
          (std-function (new qualified-name public "eval") global_eval 1)
          (std-function (new qualified-name public "parseInt") global_parseInt 2)
          (std-function (new qualified-name public "parseLong") global_parseLong 2)
          (std-function (new qualified-name public "parseFloat") global_parseFloat 1)
          (std-function (new qualified-name public "isNaN") global_isNaN 1)
          (std-function (new qualified-name public "isFinite") global_isFinite 1)
          (std-function (new qualified-name public "decodeURI") global_decodeURI 1)
          (std-function (new qualified-name public "decodeURIComponent") global_decodeURIComponent 1)
          (std-function (new qualified-name public "encodeURI") global_encodeURI 1)
          (std-function (new qualified-name public "encodeURIComponent") global_encodeURIComponent 1)
          
          (std-const-binding (new qualified-name public "Object") -class -object)
          (std-const-binding (new qualified-name public "Never") -class -never)
          (std-const-binding (new qualified-name public "Void") -class -void)
          (std-const-binding (new qualified-name public "Null") -class -null)
          (std-const-binding (new qualified-name public "Boolean") -class -boolean)
          (std-const-binding (new qualified-name public "GeneralNumber") -class -general-number)
          (std-const-binding (new qualified-name public "long") -class \#long)
          (std-const-binding (new qualified-name public "ulong") -class ulong)
          (std-const-binding (new qualified-name public "float") -class float)
          (std-const-binding (new qualified-name public "Number") -class -number)
          (std-const-binding (new qualified-name public "sbyte") -class sbyte)
          (std-const-binding (new qualified-name public "byte") -class byte)
          (std-const-binding (new qualified-name public "short") -class short)
          (std-const-binding (new qualified-name public "ushort") -class ushort)
          (std-const-binding (new qualified-name public "int") -class int)
          (std-const-binding (new qualified-name public "uint") -class uint)
          (std-const-binding (new qualified-name public "char") -class char)
          (std-const-binding (new qualified-name public "String") -class -string)
          (std-const-binding (new qualified-name public "Array") -class -array)
          (std-const-binding (new qualified-name public "Namespace") -class -namespace)
          (std-const-binding (new qualified-name public "Attribute") -class -attribute)
          (std-const-binding (new qualified-name public "Date") -class -date)
          (std-const-binding (new qualified-name public "RegExp") -class -reg-exp)
          (std-const-binding (new qualified-name public "Class") -class -class)
          (std-const-binding (new qualified-name public "Function") -class -function)
          (std-const-binding (new qualified-name public "PrototypeFunction") -class -prototype-function)
          (std-const-binding (new qualified-name public "Package") -class -package)
          (std-const-binding (new qualified-name public "Error") -class -error)
          (std-const-binding (new qualified-name public "ArgumentError") -class -argument-error)
          (std-const-binding (new qualified-name public "AttributeError") -class -attribute-error)
          (std-const-binding (new qualified-name public "ConstantError") -class -constant-error)
          (std-const-binding (new qualified-name public "DefinitionError") -class -definition-error)
          (std-const-binding (new qualified-name public "EvalError") -class -eval-error)
          (std-const-binding (new qualified-name public "RangeError") -class -range-error)
          (std-const-binding (new qualified-name public "ReferenceError") -class -reference-error)
          (std-const-binding (new qualified-name public "SyntaxError") -class -syntax-error)
          (std-const-binding (new qualified-name public "TypeError") -class -type-error)
          (std-const-binding (new qualified-name public "UninitializedError") -class -uninitialized-error)
          (std-const-binding (new qualified-name public "URIError") -class -u-r-i-error)
          )
         -object-prototype "" none false internal)))
    
    
    (%heading (2 :semantics) "Built-in Namespaces")
    (define public namespace (new namespace "public"))
    (define internal namespace (new namespace "internal"))
    
    (%heading (2 :semantics) "Built-in Attributes")
    (define global_explicit compound-attribute (new compound-attribute (list-set-of namespace) true false false none none false false))
    (define global_enumerable compound-attribute (new compound-attribute (list-set-of namespace) false true false none none false false))
    (define global_dynamic compound-attribute (new compound-attribute (list-set-of namespace) false false true none none false false))
    (define global_static compound-attribute (new compound-attribute (list-set-of namespace) false false false static none false false))
    (define global_virtual compound-attribute (new compound-attribute (list-set-of namespace) false false false virtual none false false))
    (define global_final compound-attribute (new compound-attribute (list-set-of namespace) false false false final none false false))
    (define global_prototype compound-attribute (new compound-attribute (list-set-of namespace) false false false none none true false))
    (define global_unused compound-attribute (new compound-attribute (list-set-of namespace) false false false none none false true))
    (define (global_override (this object :unused) (f simple-instance :unused) (args (vector object)) (phase phase :unused)) object
      (note "This function does not check " (:local phase) " and therefore can be used in a constant expression.")
      (var override-mod override-modifier)
      (cond
       ((empty args) (<- override-mod true))
       ((= (length args) 1)
        (const arg object (nth args 0))
        (rwhen (not-in arg (tag true false undefined) :narrow-false)
          (throw-error -type-error))
        (<- override-mod arg))
       (nil (throw-error -argument-error "too many arguments supplied")))
      (return (new compound-attribute (list-set-of namespace) false false false none override-mod false false)))
    
    
    (%heading (2 :semantics) "Built-in Functions")
    
    (define (global_eval (this object :unused) (f simple-instance :unused) (args (vector object) :unused) (phase phase :unused)) object
      (todo))
    
    
    (define (global_parseInt (this object :unused) (f simple-instance :unused) (args (vector object)) (phase phase)) float64
      (note "This function can be used in a constant expression if the arguments can be converted to primitives in constant expressions.")
      (rwhen (set-not-in (length args) (range-set-of integer 1 2))
        (throw-error -argument-error "at least one and at most two arguments must be supplied"))
      (const s string (object-to-string (nth args 0) phase))
      (var radix integer (object-to-integer (default-arg args 1 +zero64) phase))
      (var i (union (exclude-zero integer) (tag +zero -zero nan)) (string-prefix-to-integer s radix))
      (return (extended-rational-to-float64 i)))
    
    (define (string-prefix-to-integer (s string) (radix integer))
            (union (exclude-zero integer) (tag +zero -zero nan))
      (var r integer radix)
      (rwhen (set-not-in r (range-set-of-ranges integer 0 nil 2 36))
        (throw-error -range-error "radix out of range"))
      (var i integer 0)
      (while (and (< i (length s))
                  (lisp-call white-space-or-line-terminator-char? ((nth s i))
                             boolean
                    "the nonterminal " (:grammar-symbol :white-space-or-line-terminator-char nil "lexer-semantics.html") " can expand into " (:expr string (vector (nth s i)))))
        (<- i (+ i 1)))
      (var sign (integer-list -1 1) 1)
      (when (< i (length s))
        (cond
         ((= (nth s i) #\+ char16)
          (<- i (+ i 1)))
         ((= (nth s i) #\- char16)
          (<- sign -1)
          (<- i (+ i 1)))))
      (when (and (set-in r (list-set 0 16))
                 (<= (+ i 2) (length s))
                 (set-in (subseq s i (+ i 1)) (list-set "0x" "0X")))
        (<- r 16)
        (<- i (+ i 2)))
      (when (= r 0)
        (<- r 10))
      (var n integer 0)
      (const start integer i)
      (var digit integer-opt 0)
      (while (and (< i (length s)) (not-in digit (tag none)))
        (const ch char16 (nth s i))
        (cond
         ((set-in ch (range-set-of-ranges char16 #\0 #\9))
          (<- digit (- (char16-to-integer ch) (char16-to-integer #\0))))
         ((set-in ch (range-set-of-ranges char16 #\A #\Z))
          (<- digit (+ (- (char16-to-integer ch) (char16-to-integer #\A)) 10)))
         ((set-in ch (range-set-of-ranges char16 #\a #\z))
          (<- digit (+ (- (char16-to-integer ch) (char16-to-integer #\a)) 10)))
         (nil (<- digit none)))
        (when (and (not-in digit (tag none) :narrow-true) (>= digit r))
          (<- digit none :end-narrow))
        (when (not-in digit (tag none) :narrow-true)
          (<- n (+ (* n r) digit))
          (<- i (+ i 1))))
      (rwhen (= i start)
        (return nan))
      (cond
       ((/= n 0) (return (* n sign)))
       ((> sign 0) (return +zero))
       (nil (return -zero))))
      
    (define (global_parseLong (this object :unused) (f simple-instance :unused) (args (vector object)) (phase phase)) general-number
      (note "This function can be used in a constant expression if the arguments can be converted to primitives in constant expressions.")
      (rwhen (set-not-in (length args) (range-set-of integer 1 2))
        (throw-error -argument-error "at least one and at most two arguments must be supplied"))
      (const s string (object-to-string (nth args 0) phase))
      (var radix integer (object-to-integer (default-arg args 1 +zero64) phase))
      (var i (union (exclude-zero integer) (tag +zero -zero nan)) (string-prefix-to-integer s radix))
      (case i
        (:select (tag +zero -zero) (return (new long 0)))
        (:narrow integer (return (integer-to-long i)))
        (:select (tag nan) (return nan64))))
    
    
    (define (global_parseFloat (this object :unused) (f simple-instance :unused) (args (vector object)) (phase phase)) float64
      (note "This function can be used in a constant expression if its argument can be converted to a primitive in a constant expression.")
      (rwhen (/= (length args) 1)
        (throw-error -argument-error "exactly one argument must be supplied"))
      (const s string (object-to-string (nth args 0) phase))
      (/* "Apply the lexer grammar with the start symbol " (:grammar-symbol :string-decimal-literal nil "lexer-semantics.html") " to the string " (:local s)
          ". If the grammar can interpret neither " (:local s) " nor any prefix of " (:local s) " as an expansion of "
          (:grammar-symbol :string-decimal-literal nil "lexer-semantics.html") ", then " (:keyword return) :nbsp (:tag nan64)
          ". Otherwise, let " (:local p) " be the longest prefix of " (:local s) " (possibly " (:local s) " itself) such that " (:local p)
          " is an expansion of " (:grammar-symbol :string-decimal-literal nil "lexer-semantics.html") ".")
      (const q (union extended-rational (tag syntax-error))
        (lisp-call string-prefix-to-float (s)
                   (union extended-rational (tag syntax-error))
          "the result of lexing the longest possible prefix of " (:operand 0) " using " (:grammar-symbol :string-decimal-literal nil "lexer-semantics.html")
          " as the start symbol"))
      (rwhen (in q (tag syntax-error) :narrow-false)
        (return nan64))
      (*/)
      (// (:local q) ":" :nbsp (:type extended-rational) " " :assign-10 " the value of the action " (:action lex) " applied to "
          (:local p) :apostrophe "s expansion of the nonterminal " (:grammar-symbol :string-decimal-literal nil "lexer-semantics.html") ";")
      (return (extended-rational-to-float64 q)))
    
    
    (define (global_isNaN (this object :unused) (f simple-instance :unused) (args (vector object)) (phase phase)) \#boolean
      (note "This function can be used in a constant expression if its argument can be converted to a primitive in a constant expression.")
      (rwhen (/= (length args) 1)
        (throw-error -argument-error "exactly one argument must be supplied"))
      (const x general-number (object-to-general-number (nth args 0) phase))
      (return (in x (tag nan32 nan64))))
    
    
    (define (global_isFinite (this object :unused) (f simple-instance :unused) (args (vector object)) (phase phase)) \#boolean
      (note "This function can be used in a constant expression if its argument can be converted to a primitive in a constant expression.")
      (rwhen (/= (length args) 1)
        (throw-error -argument-error "exactly one argument must be supplied"))
      (const x general-number (object-to-general-number (nth args 0) phase))
      (return (not-in x (tag nan32 nan64 +infinity32 +infinity64 -infinity32 -infinity64))))
    
    
    (define (global_decodeURI (this object :unused) (f simple-instance :unused) (args (vector object) :unused) (phase phase :unused)) object
      (todo))
    
    
    (define (global_decodeURIComponent (this object :unused) (f simple-instance :unused) (args (vector object) :unused) (phase phase :unused)) object
      (todo))
    
    
    (define (global_encodeURI (this object :unused) (f simple-instance :unused) (args (vector object) :unused) (phase phase :unused)) object
      (todo))
    
    
    (define (global_encodeURIComponent (this object :unused) (f simple-instance :unused) (args (vector object) :unused) (phase phase :unused)) object
      (todo))
    
    
    
    (%heading (1 :semantics) "Built-in Classes")
    (define (dummy-call (this object :unused) (c class :unused) (args (vector object) :unused) (phase phase :unused)) object
      (todo))
    (define (dummy-construct (c class :unused) (args (vector object) :unused) (phase phase :unused)) object
      (todo))
    
    
    (define prototypes-sealed boolean false)
    
    
    (%heading (2 :semantics) "Object")
    (define -object class
      (new class
        (list-set-of local-binding)
        (list-set-of instance-property)
        none (delay -object-prototype) true
        "Object" "object" :uninit true false undefined hint-number
        ordinary-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate
        call-object construct-object none ordinary-is coerce-object))
    
    (define (call-object (this object :unused) (c class :unused) (args (vector object)) (phase phase :unused)) object
      (note "This function does not check " (:local phase) " and therefore can be used in a constant expression.")
      (cond
       ((= (length args) 0) (return undefined))
       ((= (length args) 1) (return (nth args 0)))
       (nil (throw-error -argument-error "at most one argument can be supplied"))))
    
    (define (construct-object (c class :unused) (args (vector object)) (phase phase :unused)) object
      (note "This function does not check " (:local phase) " and therefore can be used in a constant expression.")
      (rwhen (> (length args) 1)
        (throw-error -argument-error "at most one argument can be supplied"))
      (const o object (default-arg args 0 undefined))
      (if (in o (tag null undefined))
        (return (create-simple-instance -object -object-prototype none none none))
        (return o)))
    
    (define (coerce-object (o object) (c class :unused)) object-opt
      (return o))
    
    (define -object-prototype simple-instance
      (new simple-instance
        (%list-set
         (std-const-binding (new qualified-name public "constructor") -class -object)
         (std-function (new qualified-name public "toString") -object_to-string 0)
         (std-function (new qualified-name public "toLocaleString") -object_to-locale-string 0)
         (std-function (new qualified-name public "valueOf") -object_value-of 0)
         (std-function (new qualified-name public "hasOwnProperty") -object_has-own-property 1)
         (std-function (new qualified-name public "isPrototypeOf") -object_is-prototype-of 1)
         (std-function (new qualified-name public "propertyIsEnumerable") -object_property-is-enumerable 1)
         (std-function (new qualified-name public "sealProperty") -object_seal-property 1))
        none prototypes-sealed -object
        (list-set-of slot) none none none))
    
    
    (define (-object_to-string (this object) (f simple-instance :unused) (args (vector object) :unused) (phase phase :unused)) string
      (note "This function does not check " (:local phase) " and therefore can be used in a constant expression.")
      (note "This function ignores any arguments passed to it in " (:local args) ".")
      (const c class (object-type this))
      (return (append "[object " (& name c) "]")))
    
    
    (define (-object_to-locale-string (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object
      (rwhen (in phase (tag compile))
        (throw-error -constant-error (:character-literal "toLocaleString") " cannot be called from a constant expression"))
      (const to-string-method object (dot-read this (list-set (new qualified-name public "toString")) phase))
      (return (call this to-string-method args phase)))
    
    
    (define (-object_value-of (this object) (f simple-instance :unused) (args (vector object) :unused) (phase phase :unused)) object
      (note "This function does not check " (:local phase) " and therefore can be used in a constant expression.")
      (note "This function ignores any arguments passed to it in " (:local args) ".")
      (return this))
    
    
    (define (-object_has-own-property (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) \#boolean
      (rwhen (in phase (tag compile))
        (throw-error -constant-error (:character-literal "hasOwnProperty") " cannot be called from a constant expression"))
      (rwhen (/= (length args) 1)
        (throw-error -argument-error "exactly one argument must be supplied"))
      (return (has-property this (nth args 0) true phase)))
    
    
    (define (-object_is-prototype-of (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) \#boolean
      (rwhen (in phase (tag compile))
        (throw-error -constant-error (:character-literal "isPrototypeOf") " cannot be called from a constant expression"))
      (rwhen (/= (length args) 1)
        (throw-error -argument-error "exactly one argument must be supplied"))
      (const o object (nth args 0))
      (return (set-in this (archetypes o))))
    
    
    (define (-object_property-is-enumerable (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) \#boolean
      (rwhen (in phase (tag compile))
        (throw-error -constant-error (:character-literal "propertyIsEnumerable") " cannot be called from a constant expression"))
      (rwhen (/= (length args) 1)
        (throw-error -argument-error "exactly one argument must be supplied"))
      (const qname qualified-name (object-to-qualified-name (nth args 0) phase))
      (const c class (object-type this))
      (var m-base instance-property-opt (find-base-instance-property c (list-set qname) read))
      (when (not-in m-base (tag none) :narrow-true)
        (const m instance-property (get-derived-instance-property c m-base read))
        (rwhen (&opt enumerable m)
          (return true)))
      (<- m-base (find-base-instance-property c (list-set qname) write))
      (when (not-in m-base (tag none) :narrow-true)
        (const m instance-property (get-derived-instance-property c m-base write))
        (rwhen (&opt enumerable m)
          (return true)))
      (rwhen (not-in this binding-object :narrow-false)
        (return false))
      (return (some (& local-bindings this) b (and (= (& qname b) qname qualified-name) (& enumerable b)))))
    
    
    (define (-object_seal-property (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) undefined
      (rwhen (in phase (tag compile))
        (throw-error -constant-error (:character-literal "sealProperty") " cannot be called from a constant expression"))
      (rwhen (> (length args) 1)
        (throw-error -argument-error "at most one argument can be supplied"))
      (const arg object (default-arg args 0 true))
      (cond
       ((in arg (tag false) :narrow-false)
        (seal-object this))
       ((in arg (tag true) :narrow-false)
        (seal-object this)
        (seal-all-local-properties this))
       ((in arg (union char16 string))
        (rwhen (not (has-property this arg true phase))
          (throw-error -reference-error "property not found"))
        (const qname qualified-name (object-to-qualified-name arg phase))
        (seal-local-property this qname)))
      (return undefined))

    
    
    (%heading (2 :semantics) "Never")
    (define -never class
      (new class
        (list-set-of local-binding) (list-set-of instance-property) -object none true
        "Never" "" :uninit false true none :uninit
        ordinary-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate
        same-as-construct construct-never none ordinary-is coerce-never))
    
    (define (construct-never (c class :unused) (args (vector object)) (phase phase :unused)) object
      (rwhen (> (length args) 1)
        (throw-error -argument-error "at most one argument can be supplied"))
      (throw-error -type-error "no coercions to " (:character-literal "Never") " are possible"))
    
    (define (coerce-never (o object :unused) (c class :unused)) (tag none)
      (return none))
    
    
    (%heading (2 :semantics) "Void")
    (define -void class
      (new class
        (list-set-of local-binding) (list-set-of instance-property) -object none true
        "Void" "undefined" :uninit false true undefined :uninit
        ordinary-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate
        call-void construct-void none ordinary-is coerce-void))
    
    (define (call-void (this object :unused) (c class :unused) (args (vector object)) (phase phase :unused)) undefined
      (note "This function does not check " (:local phase) " and therefore can be used in a constant expression.")
      (rwhen (> (length args) 1)
        (throw-error -argument-error "at most one argument can be supplied"))
      (return undefined))
    
    (define (construct-void (c class :unused) (args (vector object)) (phase phase :unused)) undefined
      (note "This function does not check " (:local phase) " and therefore can be used in a constant expression.")
      (rwhen (/= (length args) 0)
        (throw-error -argument-error "no arguments can be supplied"))
      (return undefined))
    
    (define (coerce-void (o object) (c class :unused)) (tag undefined none)
      (if (in o (union null undefined))
        (return undefined)
        (return none)))
    
    
    (%heading (2 :semantics) "Null")
    (define -null class
      (new class
        (list-set-of local-binding) (list-set-of instance-property) -object none true
        "Null" "object" :uninit false true null :uninit
        ordinary-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate
        call-null construct-null none ordinary-is coerce-null))
    
    (define (call-null (this object :unused) (c class :unused) (args (vector object)) (phase phase :unused)) null
      (note "This function does not check " (:local phase) " and therefore can be used in a constant expression.")
      (rwhen (> (length args) 1)
        (throw-error -argument-error "at most one argument can be supplied"))
      (return null))
    
    (define (construct-null (c class :unused) (args (vector object)) (phase phase :unused)) null
      (note "This function does not check " (:local phase) " and therefore can be used in a constant expression.")
      (rwhen (/= (length args) 0)
        (throw-error -argument-error "no arguments can be supplied"))
      (return null))
    
    (define (coerce-null (o object) (c class :unused)) (tag null none)
      (if (in o (tag null) :narrow-true)
        (return o)
        (return none)))
    
    
    (%heading (2 :semantics) "Boolean")
    (define -boolean class
      (new class
        (list-set-of local-binding) (list-set-of instance-property) -object (delay -boolean-prototype) true
        "Boolean" "boolean" :uninit false true false :uninit
        ordinary-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate
        same-as-construct construct-boolean none ordinary-is coerce-boolean))
    
    (define (construct-boolean (c class :unused) (args (vector object)) (phase phase :unused)) \#boolean
      (note "This function does not check " (:local phase) " and therefore can be used in a constant expression.")
      (rwhen (> (length args) 1)
        (throw-error -argument-error "at most one argument can be supplied"))
      (return (object-to-boolean (default-arg args 0 false))))
    
    (define (coerce-boolean (o object) (c class :unused)) boolean-opt
      (if (in o boolean :narrow-true)
        (return o)
        (return none)))
    
    (define -boolean-prototype simple-instance
      (new simple-instance
        (%list-set
         (std-const-binding (new qualified-name public "constructor") -class -boolean)
         (std-function (new qualified-name public "toString") -boolean_to-string 0)
         (std-reserve (new qualified-name public "valueOf") -object-prototype))
        -object-prototype prototypes-sealed -object
        (list-set-of slot) none none none))
    
    
    (define (-boolean_to-string (this object) (f simple-instance :unused) (args (vector object) :unused) (phase phase)) string
      (note "This function can be used in a constant expression.")
      (note "This function ignores any arguments passed to it in " (:local args) ".")
      (const a boolean (object-to-boolean this))
      (return (object-to-string a phase)))
    
    
    (%heading (2 :semantics) "GeneralNumber")
    (define -general-number class
      (new class
        (list-set-of local-binding) (list-set-of instance-property) -object (delay -general-number-prototype) true
        "GeneralNumber" "object" :uninit false true nan64 hint-number
        ordinary-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate
        same-as-construct construct-general-number none ordinary-is coerce-general-number))
    
    (define (construct-general-number (c class :unused) (args (vector object)) (phase phase)) general-number
      (note "This function can be used in a constant expression if the argument can be converted to a primitive in a constant expression.")
      (cond
       ((= (length args) 0) (return +zero64))
       ((= (length args) 1) (return (object-to-general-number (nth args 0) phase)))
       (nil (throw-error -argument-error "at most one argument can be supplied"))))
    
    (define (coerce-general-number (o object) (c class :unused)) (union general-number (tag none))
      (if (in o general-number :narrow-true)
        (return o)
        (return none)))
    
    (define -general-number-prototype simple-instance
      (new simple-instance
        (%list-set
         (std-const-binding (new qualified-name public "constructor") -class -general-number)
         (std-function (new qualified-name public "toString") -general-number_to-string 1)
         (std-reserve (new qualified-name public "valueOf") -object-prototype)
         (std-function (new qualified-name public "toFixed") -general-number_to-fixed 1)
         (std-function (new qualified-name public "toExponential") -general-number_to-exponential 1)
         (std-function (new qualified-name public "toPrecision") -general-number_to-precision 1))
        -object-prototype prototypes-sealed -object
        (list-set-of slot) none none none))
    
    
    (define (-general-number_to-string (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) string
      (note "This function can be used in a constant expression if " (:local this) " and the argument can be converted to primitives in constant expressions.")
      (note "This function is generic and can be applied even if " (:local this) " is not a general number.")
      (const x general-number (object-to-general-number this phase))
      (var radix integer (object-to-integer (default-arg args 0 10.0) phase))
      (rwhen (or (< radix 2) (> radix 36))
        (throw-error -range-error "bad radix"))
      (if (= radix 10)
        (return (general-number-to-string x))
        (return (/*/ "*****Implementation-defined" (:local x) " converted to a string containing a base-" (:local radix) " number in an implementation-defined manner"))))
    
    
    (define precision-limit integer (/*/ 100 "an implementation-defined integer not less than 20"))
    
    (define (-general-number_to-fixed (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) string
      (note "This function can be used in a constant expression if " (:local this) " and the argument can be converted to primitives in constant expressions.")
      (note "This function is generic and can be applied even if " (:local this) " is not a general number.")
      (rwhen (> (length args) 1)
        (throw-error -argument-error "at most one argument can be supplied"))
      (const x general-number (object-to-general-number this phase))
      (var fraction-digits integer (object-to-integer (default-arg args 0 +zero64) phase))
      (rwhen (or (< fraction-digits 0) (> fraction-digits precision-limit))
        (throw-error -range-error))
      (rwhen (not-in x finite-general-number :narrow-false)
        (return (general-number-to-string x)))
      (var r rational (to-rational x))
      (when (>= (rat-abs r) (expt 10 21) rational)
        (return (general-number-to-string x)))
      (var sign string "")
      (when (< r 0 rational)
        (<- sign "-")
        (<- r (rat-neg r)))
      (const n integer (floor (rat+ (rat* r (expt 10 fraction-digits)) (rat/ 1 2))))
      (var digits string (integer-to-string n))
      (cond
       ((= fraction-digits 0)
        (return (append sign digits)))
       (nil
        (when (<= (length digits) fraction-digits)
          (<- digits (append (repeat char16 #\0 (- (+ fraction-digits 1) (length digits))) digits)))
        (const k integer (- (length digits) fraction-digits))
        (return (append sign (subseq digits 0 (- k 1)) "." (subseq digits k))))))
    
    
    (define (-general-number_to-exponential (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) string
      (note "This function can be used in a constant expression if " (:local this) " and the argument can be converted to primitives in constant expressions.")
      (note "This function is generic and can be applied even if " (:local this) " is not a general number.")
      (rwhen (> (length args) 1)
        (throw-error -argument-error "at most one argument can be supplied"))
      (const x general-number (object-to-general-number this phase))
      (var fraction-digits extended-integer (object-to-extended-integer (default-arg args 0 nan64) phase))
      (rwhen (or (in fraction-digits (tag +infinity -infinity) :narrow-false) (and (not-in fraction-digits (tag nan) :narrow-true)
                                                                                   (or (< fraction-digits 0) (> fraction-digits precision-limit))))
        (throw-error -range-error))
      (rwhen (not-in x finite-general-number :narrow-false)
        (return (general-number-to-string x)))
      (var r rational (to-rational x))
      (var sign string "")
      (when (< r 0 rational)
        (<- sign "-")
        (<- r (rat-neg r)))
      (var digits string)
      (var e integer)
      (cond
       ((not-in fraction-digits (tag nan) :narrow-true)
        (cond
         ((= r 0 rational)
          (<- digits (repeat char16 #\0 (+ fraction-digits 1)))
          (<- e 0))
         (nil
          (<- e (floor-log10 r))
          (var n integer (floor (rat+ (rat* r (expt 10 (- fraction-digits e))) (rat/ 1 2))))
          (assert (cascade rational (expt 10 fraction-digits) <= n <= (expt 10 (+ fraction-digits 1))) "At this point " (:assertion))
          (when (= n (expt 10 (+ fraction-digits 1)) rational)
            (<- n (int/ n 10))
            (<- e (+ e 1)))
          (<- digits (integer-to-string n))))
        (assert (= (length digits) (+ fraction-digits 1)) "At this point the string " (:local digits) " has exactly " (:expr integer (+ fraction-digits 1)) " digits"))
       ((= r 0 rational)
        (<- digits "0")
        (<- e 0))
       ((in x (union long u-long) :narrow-false)
        (<- digits (integer-to-string (assert-in r integer)))
        (<- e (- (length digits) 1))
        (while (= (nth digits (- (length digits) 1)) #\0 char16)
          (<- digits (subseq digits 0 (- (length digits) 2)))))
       (nil
        (quiet-assert (not-in x (tag +zero32 -zero32 +zero64 -zero64) :narrow-true))
        (var k integer)
        (var s integer)
        (case x
          (:narrow nonzero-finite-float32
            (/* (:initialize e) (:initialize k) (:initialize s)
                "Let " (:local e) ", " (:local k) ", and " (:local s) " be integers such that "
                (:expr boolean (>= k 1)) ", " (:expr boolean (cascade rational (expt 10 (- k 1)) <= s <= (expt 10 k))) ", "
                (:expr boolean (= (real-to-float32 (rat* s (expt 10 (- (+ e 1) k)))) x float32)) ", and " (:local k) " is as small as possible.")
            (multiple-value-bind ((digits2 string) (e2 integer)) decompose-positive-float32 ((if (< r 0 rational) (float32-negate x) x)))
            (<- digits digits2)
            (<- e e2)
            (<- k (length digits))
            (<- s k) ;Shut up unreference variable warnings
            (<- k s)
            (*/))
          (:narrow nonzero-finite-float64
            (/* (:initialize e) (:initialize k) (:initialize s)
                "Let " (:local e) ", " (:local k) ", and " (:local s) " be integers such that "
                (:expr boolean (>= k 1)) ", " (:expr boolean (cascade rational (expt 10 (- k 1)) <= s <= (expt 10 k))) ", "
                (:expr boolean (= (real-to-float64 (rat* s (expt 10 (- (+ e 1) k)))) x float64)) ", and " (:local k) " is as small as possible.")
            (multiple-value-bind ((digits2 string) (e2 integer)) decompose-positive-float64 ((if (< r 0 rational) (float64-negate x) x)))
            (<- digits digits2)
            (<- e e2)
            (<- k (length digits))
            (<- s k) ;Shut up unreference variable warnings
            (<- k s)
            (*/)))
        (note (:local k) " is the number of digits in the decimal representation of " (:local s) ", " (:local s)
              " is not divisible by 10, and the least significant digit of " (:local s)
              " is not necessarily uniquely determined by the above criteria.")
        (// "When there are multiple possibilities for " (:local s) " according to the rules above, "
            "implementations are encouraged but not required to select the one according to the following rules: "
            "Select the value of " (:local s) " for which " (:expr rational (rat* s (expt 10 (- (+ e 1) k)))) " is closest in value to " (:local r)
            "; if there are two such possible values of " (:local s) ", choose the one that is even.")
        (// (:local digits) :nbsp :assign-10 :nbsp (:expr string (integer-to-string s)))))
      (return (append sign (exponential-notation-string digits e))))
    
    
    (define (-general-number_to-precision (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) string
      (note "This function can be used in a constant expression if " (:local this) " and the argument can be converted to primitives in constant expressions.")
      (note "This function is generic and can be applied even if " (:local this) " is not a general number.")
      (rwhen (> (length args) 1)
        (throw-error -argument-error "at most one argument can be supplied"))
      (const x general-number (object-to-general-number this phase))
      (var precision extended-integer (object-to-extended-integer (default-arg args 0 nan64) phase))
      (rwhen (in precision (tag nan) :narrow-false)
        (return (general-number-to-string x)))
      (rwhen (or (in precision (tag +infinity -infinity) :narrow-false) (< precision 1) (> precision (+ precision-limit 1)))
        (throw-error -range-error))
      (rwhen (not-in x finite-general-number :narrow-false)
        (return (general-number-to-string x)))
      (var r rational (to-rational x))
      (var sign string "")
      (when (< r 0 rational)
        (<- sign "-")
        (<- r (rat-neg r)))
      (var digits string)
      (var e integer)
      (cond
       ((= r 0 rational)
        (<- digits (repeat char16 #\0 precision))
        (<- e 0))
       (nil
        (<- e (floor-log10 r))
        (var n integer (floor (rat+ (rat* r (expt 10 (- (- precision 1) e))) (rat/ 1 2))))
        (assert (cascade rational (expt 10 (- precision 1)) <= n <= (expt 10 precision)) "At this point " (:assertion))
        (when (= n (expt 10 precision) rational)
          (<- n (int/ n 10))
          (<- e (+ e 1)))
        (<- digits (integer-to-string n))))
      (assert (= (length digits) precision) "At this point the string " (:local digits) " has exactly " (:local precision) " digits")
      (cond
       ((or (< e -6) (>= e precision))
        (return (append sign (exponential-notation-string digits e))))
       ((= e (- precision 1))
        (return (append sign digits)))
       ((>= e 0)
        (return (append sign (subseq digits 0 e) "." (subseq digits (+ e 1)))))
       (nil
        (return (append sign "0." (repeat char16 #\0 (neg (+ e 1))) digits)))))
    
    
    (%heading (2 :semantics) "long")
    (define \#long class
      (new class
        (%list-set
         (std-const-binding (new qualified-name public "MAX_VALUE") (delay ulong) (new long (- (expt 2 63) 1)))
         (std-const-binding (new qualified-name public "MIN_VALUE") (delay ulong) (new long (neg (expt 2 63)))))
        (list-set-of instance-property) -general-number (delay long-prototype) true
        "long" "long" :uninit false true (new long 0) :uninit
        ordinary-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate
        same-as-construct construct-long none ordinary-is coerce-long))
    
    (define (construct-long (c class :unused) (args (vector object)) (phase phase)) long
      (note "This function can be used in a constant expression if the argument can be converted to a primitive in a constant expression.")
      (rwhen (> (length args) 1)
        (throw-error -argument-error "at most one argument can be supplied"))
      (const arg object (default-arg args 0 +zero64))
      (const i integer (object-to-integer arg phase))
      (if (cascade integer (neg (expt 2 63)) <= i <= (- (expt 2 63) 1))
        (return (new long i))
        (throw-error -range-error (:local i) " is out of the " (:type long) " range")))
    
    (define (coerce-long (o object) (c class :unused)) (union long (tag none))
      (rwhen (not-in o general-number :narrow-false)
        (return none))
      (const i integer-opt (check-integer o))
      (if (and (not-in i (tag none) :narrow-true) (cascade integer (neg (expt 2 63)) <= i <= (- (expt 2 63) 1)))
        (return (new long i))
        (throw-error -range-error (:local i) " is out of the " (:type long) " range")))
    
    (define long-prototype simple-instance
      (new simple-instance
        (%list-set
         (std-const-binding (new qualified-name public "constructor") -class \#long)
         (std-reserve (new qualified-name public "toString") -general-number-prototype)
         (std-reserve (new qualified-name public "valueOf") -general-number-prototype))
        -general-number-prototype prototypes-sealed -object
        (list-set-of slot) none none none))
    
    
    (%heading (2 :semantics) "ulong")
    (define ulong class
      (new class
        (%list-set
         (std-const-binding (new qualified-name public "MAX_VALUE") (delay ulong) (new u-long (- (expt 2 64) 1)))
         (std-const-binding (new qualified-name public "MIN_VALUE") (delay ulong) (new u-long 0)))
        (list-set-of instance-property) -general-number (delay ulong-prototype) true
        "ulong" "ulong" :uninit false true (new u-long 0) :uninit
        ordinary-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate
        same-as-construct construct-u-long none ordinary-is coerce-u-long))
    
    (define (construct-u-long (c class :unused) (args (vector object)) (phase phase)) u-long
      (note "This function can be used in a constant expression if the argument can be converted to a primitive in a constant expression.")
      (rwhen (> (length args) 1)
        (throw-error -argument-error "at most one argument can be supplied"))
      (const arg object (default-arg args 0 +zero64))
      (const i integer (object-to-integer arg phase))
      (if (cascade integer 0 <= i <= (- (expt 2 64) 1))
        (return (new u-long i))
        (throw-error -range-error (:local i) " is out of the " (:type u-long) " range")))
    
    (define (coerce-u-long (o object) (c class :unused)) (union u-long (tag none))
      (rwhen (not-in o general-number :narrow-false)
        (return none))
      (const i integer-opt (check-integer o))
      (if (and (not-in i (tag none) :narrow-true) (cascade integer 0 <= i <= (- (expt 2 64) 1)))
        (return (new u-long i))
        (throw-error -range-error (:local i) " is out of the " (:type u-long) " range")))
    
    (define ulong-prototype simple-instance
      (new simple-instance
        (%list-set
         (std-const-binding (new qualified-name public "constructor") -class ulong)
         (std-reserve (new qualified-name public "toString") -general-number-prototype)
         (std-reserve (new qualified-name public "valueOf") -general-number-prototype))
        -general-number-prototype prototypes-sealed -object
        (list-set-of slot) none none none))
    
    
    (%heading (2 :semantics) "float")
    (define float class
      (new class
        (%list-set
         (std-const-binding (new qualified-name public "MAX_VALUE") (delay float) (float32 3.4028235e+38))
         (std-const-binding (new qualified-name public "MIN_VALUE") (delay float) (float32 1e-45))
         (std-const-binding (new qualified-name public "NaN") (delay float) nan32)
         (std-const-binding (new qualified-name public "NEGATIVE_INFINITY") (delay float) -infinity32)
         (std-const-binding (new qualified-name public "POSITIVE_INFINITY") (delay float) +infinity32))
        (list-set-of instance-property) -general-number (delay float-prototype) true
        "float" "float" :uninit false true nan32 :uninit
        ordinary-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate
        same-as-construct construct-float none ordinary-is coerce-float))
    
    (define (construct-float (c class :unused) (args (vector object)) (phase phase)) float32
      (note "This function can be used in a constant expression if the argument can be converted to a primitive in a constant expression.")
      (cond
       ((= (length args) 0) (return +zero32))
       ((= (length args) 1) (return (object-to-float32 (nth args 0) phase)))
       (nil (throw-error -argument-error "at most one argument can be supplied"))))
    
    (define (coerce-float (o object) (c class :unused)) (union float32 (tag none))
      (if (in o general-number :narrow-true)
        (return (to-float32 o))
        (return none)))
    
    (define float-prototype simple-instance
      (new simple-instance
        (%list-set
         (std-const-binding (new qualified-name public "constructor") -class float)
         (std-reserve (new qualified-name public "toString") -general-number-prototype)
         (std-reserve (new qualified-name public "valueOf") -general-number-prototype))
        -general-number-prototype prototypes-sealed -object
        (list-set-of slot) none none none))
    
    
    (%heading (2 :semantics) "Number")
    (define -number class
      (new class
        (%list-set
         (std-const-binding (new qualified-name public "MAX_VALUE") (delay -number) 1.7976931348623157e+308)
         (std-const-binding (new qualified-name public "MIN_VALUE") (delay -number) 5e-324)
         (std-const-binding (new qualified-name public "NaN") (delay -number) nan64)
         (std-const-binding (new qualified-name public "NEGATIVE_INFINITY") (delay -number) -infinity64)
         (std-const-binding (new qualified-name public "POSITIVE_INFINITY") (delay -number) +infinity64))
        (list-set-of instance-property) -general-number (delay -number-prototype) true
        "Number" "number" :uninit false true nan64 :uninit
        ordinary-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate
        same-as-construct construct-number none ordinary-is coerce-number))
    
    (define (construct-number (c class :unused) (args (vector object)) (phase phase)) float64
      (note "This function can be used in a constant expression if the argument can be converted to a primitive in a constant expression.")
      (cond
       ((= (length args) 0) (return +zero64))
       ((= (length args) 1) (return (object-to-float64 (nth args 0) phase)))
       (nil (throw-error -argument-error "at most one argument can be supplied"))))
    
    (define (coerce-number (o object) (c class :unused)) (union float64 (tag none))
      (if (in o general-number :narrow-true)
        (return (to-float64 o))
        (return none)))
    
    (define -number-prototype simple-instance
      (new simple-instance
        (%list-set
         (std-const-binding (new qualified-name public "constructor") -class -number)
         (std-reserve (new qualified-name public "toString") -general-number-prototype)
         (std-reserve (new qualified-name public "valueOf") -general-number-prototype))
        -general-number-prototype prototypes-sealed -object
        (list-set-of slot) none none none))
    
    
    
    (define (make-built-in-integer-class (name string) (low integer) (high integer)) class
      (function (construct (c class :unused) (args (vector object)) (phase phase)) float64
        (note "This function can be used in a constant expression if the argument can be converted to a primitive in a constant expression.")
        (rwhen (> (length args) 1)
          (throw-error -argument-error "at most one argument can be supplied"))
        (const arg object (default-arg args 0 +zero64))
        (const x float64 (object-to-float64 arg phase))
        (const i integer-opt (check-integer x))
        (rwhen (and (not-in i (tag none) :narrow-true) (cascade integer low <= i <= high))
          (note (:tag -zero64) " is coerced to " (:tag +zero64) ".")
          (return (real-to-float64 i)))
        (throw-error -range-error))
      (function (is (o object) (c class :unused)) boolean
        (rwhen (not-in o float64 :narrow-false)
          (return false))
        (const i integer-opt (check-integer o))
        (return (and (not-in i (tag none) :narrow-true) (cascade integer low <= i <= high))))
      (function (coerce (o object) (c class :unused)) (union float64 (tag none))
        (rwhen (not-in o general-number :narrow-false)
          (return none))
        (const i integer-opt (check-integer o))
        (rwhen (and (not-in i (tag none) :narrow-true) (cascade integer low <= i <= high))
          (note (:tag -zero32) ", " (:tag +zero32) ", and " (:tag -zero64) " are all coerced to " (:tag +zero64) ".")
          (return (real-to-float64 i)))
        (throw-error -range-error))
      (return (new class
                (%list-set
                 (std-const-binding (new qualified-name public "MAX_VALUE") -number (real-to-float64 high))
                 (std-const-binding (new qualified-name public "MIN_VALUE") -number (real-to-float64 low)))
                (list-set-of instance-property) -number (&opt prototype -number) true
                name "number" :uninit false true +zero64 :uninit
                (& has-property -number) (& bracket-read -number) (& bracket-write -number) (& bracket-delete -number)
                (& read -number) (& write -number) (& delete -number)
                (& enumerate -number)
                same-as-construct construct none is coerce)))
    
    (define sbyte class (make-built-in-integer-class "sbyte" -128 127))
    (define byte class (make-built-in-integer-class "byte" 0 255))
    (define short class (make-built-in-integer-class "short" -32768 32767))
    (define ushort class (make-built-in-integer-class "ushort" 0 65535))
    (define int class (make-built-in-integer-class "int" -2147483648 2147483647))
    (define uint class (make-built-in-integer-class "uint" 0 4294967295))
    
    
    
    (%heading (2 :semantics) "char")
    (define char class
      (new class
        (list-set (std-function (new qualified-name public "fromCharCode") char_from-char-code 1))
        (list-set-of instance-property) -object (delay char-prototype) true
        "char" "char" :uninit false true #?0000 :uninit
        ordinary-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate
        same-as-construct construct-char none ordinary-is coerce-char))
    
    (define (call-char (this object :unused) (c class :unused) (args (vector object)) (phase phase)) char16
      (note "This function can be used in a constant expression if the argument can be converted to a primitive in a constant expression.")
      (rwhen (/= (length args) 1)
        (throw-error -argument-error "exactly one argument must be supplied"))
      (const s string (object-to-string (nth args 0) phase))
      (rwhen (/= (length s) 1)
        (throw-error -range-error "only one character may be given"))
      (return (nth s 0)))
    
    (define (construct-char (c class :unused) (args (vector object)) (phase phase)) char16
      (note "This function can be used in a constant expression if the argument can be converted to a primitive in a constant expression.")
      (rwhen (> (length args) 1)
        (throw-error -argument-error "at most one argument can be supplied"))
      (const arg object (default-arg args 0 undefined))
      (cond
       ((in arg (tag undefined)) (return #?0000))
       ((in arg char16 :narrow-true) (return arg))
       (nil
        (const s string (object-to-string (nth args 0) phase))
        (rwhen (/= (length s) 1)
          (throw-error -range-error "only one character may be given"))
        (return (nth s 0)))))
    
    (define (coerce-char (o object) (c class :unused)) (union char16 (tag none))
      (if (in o char16 :narrow-true)
        (return o)
        (return none)))
    
    
    (define (char_from-char-code (this object :unused) (f simple-instance :unused) (args (vector object)) (phase phase)) object
      (note "This function can be used in a constant expression if the argument can be converted to a primitive in a constant expression.")
      (rwhen (/= (length args) 1)
        (throw-error -argument-error "exactly one argument must be supplied"))
      (const i integer (object-to-integer (nth args 0) phase))
      (if (cascade integer 0 <= i <= (hex #xFFFF))
        (return (integer-to-char16 i))
        (throw-error -range-error "character code out of range")))
    
    
    (define char-prototype simple-instance
      (new simple-instance
        (%list-set
         (std-const-binding (new qualified-name public "constructor") -class char)
         (std-reserve (new qualified-name public "toString") -string-prototype)
         (std-reserve (new qualified-name public "valueOf") -string-prototype))
        -string-prototype prototypes-sealed -object
        (list-set-of slot) none none none))
    
    
    
    (%heading (2 :semantics) "String")
    (define -string class
      (new class
        (list-set (std-function (new qualified-name public "fromCharCode") -string_from-char-code 1))
        (%list-set-of instance-property
          (new instance-getter (list-set (new qualified-name public "length")) true false :uninit -string_length))
        -object (delay -string-prototype) true
        "String" "string" :uninit false true null :uninit
        string-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete read-string ordinary-write ordinary-delete ordinary-enumerate
        same-as-construct construct-string none ordinary-is coerce-string))
    
    (define (string-has-property (o object) (c class) (property object) (flat boolean) (phase phase)) boolean
      (assert (in o string :narrow-true) (:assertion) " because " (:global string-has-property) " is only called on instances of class " (:character-literal "String") ".")
      (const qname qualified-name (object-to-qualified-name property phase))
      (const i integer-opt (multiname-to-unsigned-integer (list-set qname)))
      (cond
       ((not-in i (tag none) :narrow-true)
        (return (< i (length o))))
       (nil
        (return (or (not-in (find-base-instance-property c (list-set qname) read) (tag none))
                    (not-in (find-base-instance-property c (list-set qname) write) (tag none))
                    (not-in (find-archetype-property o (list-set qname) read flat) (tag none))
                    (not-in (find-archetype-property o (list-set qname) write flat) (tag none)))))))
    
    (define (read-string (o object) (limit class) (multiname multiname) (env environment-opt) (undefined-if-missing boolean) (phase phase))
            object-opt
      (assert (in o string :narrow-true) (:assertion) " because " (:global read-string) " is only called on instances of class " (:character-literal "String") ".")
      (when (= limit -string class)
        (const i integer-opt (multiname-to-unsigned-integer multiname))
        (when (not-in i (tag none) :narrow-true)
          (cond
           ((< i (length o)) (return (nth o i)))
           (undefined-if-missing (return undefined))
           (nil (return none)))))
      (return (ordinary-read o limit multiname env undefined-if-missing phase)))
    
    (define (construct-string (c class :unused) (args (vector object)) (phase phase)) string
      (note "This function can be used in a constant expression if the argument can be converted to a primitive in a constant expression.")
      (cond
       ((= (length args) 0) (return ""))
       ((= (length args) 1) (return (object-to-string (nth args 0) phase)))
       (nil (throw-error -argument-error "at most one argument can be supplied"))))
    
    (define (coerce-string (o object) (c class :unused)) (union string null (tag none))
      (cond
       ((in o (union null string) :narrow-true) (return o))
       ((in o char16 :narrow-true)
        (return (vector o)))
       (nil (return none))))
    
    
    (define (-string_length (this object) (phase phase :unused)) object
      (assert (in this string :narrow-true) (:assertion) " because this getter cannot be extracted from the " (:character-literal "String") " class.")
      (const length integer (length this))
      (return (real-to-float64 length)))
    
    
    (define (-string_from-char-code (this object :unused) (f simple-instance :unused) (args (vector object)) (phase phase)) object
      (note "This function can be used in a constant expression if the arguments can be converted to primitives in constant expressions.")
      (var s string "")
      (for-each args arg
        (const i integer (object-to-integer arg phase))
        (if (cascade integer 0 <= i <= (hex #x10FFFF))
          (<- s (append s (integer-to-u-t-f16 i)))
          (throw-error -range-error "character code out of range")))
      (return s))
    
    
    (define -string-prototype simple-instance
      (new simple-instance
        (%list-set
         (std-const-binding (new qualified-name public "constructor") -class -string)
         (std-function (new qualified-name public "toString") -string_to-string 0)
         (std-reserve (new qualified-name public "valueOf") -object-prototype)
         (std-function (new qualified-name public "charAt") -string_char-at 1)
         (std-function (new qualified-name public "charCodeAt") -string_char-code-at 1)
         (std-function (new qualified-name public "concat") -string_concat 1)
         (std-function (new qualified-name public "indexOf") -string_index-of 1)
         (std-function (new qualified-name public "lastIndexOf") -string_last-index-of 1)
         (std-function (new qualified-name public "localeCompare") -string_locale-compare 1)
         (std-function (new qualified-name public "match") -string_match 1)
         (std-function (new qualified-name public "replace") -string_replace 1)
         (std-function (new qualified-name public "search") -string_search 1)
         (std-function (new qualified-name public "slice") -string_slice 2)
         (std-function (new qualified-name public "split") -string_split 2)
         (std-function (new qualified-name public "substring") -string_substring 2)
         (std-function (new qualified-name public "toLowerCase") -string_to-lower-case 0)
         (std-function (new qualified-name public "toLocaleLowerCase") -string_to-locale-lower-case 0)
         (std-function (new qualified-name public "toUpperCase") -string_to-upper-case 0)
         (std-function (new qualified-name public "toLocaleUpperCase") -string_to-locale-upper-case 0))
        -object-prototype prototypes-sealed -object
        (list-set-of slot) none none none))
    
    
    (define (-string_to-string (this object) (f simple-instance :unused) (args (vector object) :unused) (phase phase)) string
      (note "This function can be used in a constant expression if " (:local this) " can be converted to a primitive in a constant expression.")
      (note "This function is generic and can be applied even if " (:local this) " is not a string.")
      (note "This function ignores any arguments passed to it in " (:local args) ".")
      (return (object-to-string this phase)))
    
    
    (define (-string_char-at (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) string
      (note "This function can be used in a constant expression if " (:local this) " and the argument can be converted to primitives in constant expressions.")
      (note "This function is generic and can be applied even if " (:local this) " is not a string.")
      (rwhen (> (length args) 1)
        (throw-error -argument-error "at most one argument can be supplied"))
      (const s string (object-to-string this phase))
      (var position extended-integer (object-to-extended-integer (default-arg args 0 +zero64) phase))
      (cond
       ((in position (tag nan) :narrow-false) (throw-error -range-error))
       ((and (not-in position (tag +infinity -infinity) :narrow-true) (cascade integer 0 <= position < (length s)))
        (return (vector (nth s position))))
       (nil (return ""))))
    
    
    (define (-string_char-code-at (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) float64
      (note "This function can be used in a constant expression if " (:local this) " and the argument can be converted to primitives in constant expressions.")
      (note "This function is generic and can be applied even if " (:local this) " is not a string.")
      (rwhen (> (length args) 1)
        (throw-error -argument-error "at most one argument can be supplied"))
      (const s string (object-to-string this phase))
      (var position extended-integer (object-to-extended-integer (default-arg args 0 +zero64) phase))
      (cond
       ((in position (tag nan) :narrow-false) (throw-error -range-error))
       ((and (not-in position (tag +infinity -infinity) :narrow-true) (cascade integer 0 <= position < (length s)))
        (return (real-to-float64 (char16-to-integer (nth s position)))))
       (nil (return nan64))))
    
    
    (define (-string_concat (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) string
      (note "This function can be used in a constant expression if " (:local this) " and the argument can be converted to primitives in constant expressions.")
      (note "This function is generic and can be applied even if " (:local this) " is not a string.")
      (var s string (object-to-string this phase))
      (for-each args arg
        (<- s (append s (object-to-string arg phase))))
      (return s))
    
    
    (define (-string_index-of (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) float64
      (note "This function can be used in a constant expression if " (:local this) " and the arguments can be converted to primitives in constant expressions.")
      (note "This function is generic and can be applied even if " (:local this) " is not a string.")
      (rwhen (set-not-in (length args) (range-set-of integer 1 2))
        (throw-error -argument-error "at least one and at most two arguments must be supplied"))
      (const s string (object-to-string this phase))
      (const pattern string (object-to-string (nth args 0) phase))
      (const arg object (default-arg args 1 +zero64))
      (var position integer (pin-extended-integer (object-to-extended-integer arg phase) (length s) false))
      (while (<= (+ position (length pattern)) (length s))
        (rwhen (= (subseq s position (+ position (- (length pattern) 1))) pattern string)
          (return (real-to-float64 position)))
        (<- position (+ position 1)))
      (return -1.0))
    
    
    (define (-string_last-index-of (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) float64
      (note "This function can be used in a constant expression if " (:local this) " and the arguments can be converted to primitives in constant expressions.")
      (note "This function is generic and can be applied even if " (:local this) " is not a string.")
      (rwhen (set-not-in (length args) (range-set-of integer 1 2))
        (throw-error -argument-error "at least one and at most two arguments must be supplied"))
      (const s string (object-to-string this phase))
      (const pattern string (object-to-string (nth args 0) phase))
      (const arg object (default-arg args 1 +infinity64))
      (var position integer (pin-extended-integer (object-to-extended-integer arg phase) (length s) false))
      (when (> (+ position (length pattern)) (length s))
        (<- position (- (length s) (length pattern))))
      (while (>= position 0)
        (rwhen (= (subseq s position (+ position (- (length pattern) 1))) pattern string)
          (return (real-to-float64 position)))
        (<- position (- position 1)))
      (return -1.0))
    
   
    (define (-string_locale-compare (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) float64
      (note "This function is generic and can be applied even if " (:local this) " is not a string.")
      (rwhen (in phase (tag compile))
        (throw-error -constant-error (:character-literal "localeCompare") " cannot be called from a constant expression"))
      (rwhen (< (length args) 1)
        (throw-error -argument-error "at least one argument must be supplied"))
      (const s1 string (object-to-string this phase))
      (const s2 string (object-to-string (nth args 0) phase))
      (/* "Let " (:local result) ":" :nbsp (:type object) " be a value of type " (:global -number) " that is the result of a locale-sensitive string comparison of "
          (:local s1) " and " (:local s2) ". The two strings are compared in an implementation-defined fashion. The result is intended to order strings in the sort order "
          "specified by the system default locale, and will be negative, zero, or positive, depending on whether " (:local s1) " comes before " (:local s2)
          " in the sort order, they are equal, or " (:local s1) " comes after " (:local s2) " in the sort order, respectively. The result shall not be "
          (:tag nan64) ". The comparison shall be a consistent comparison function on the set of all strings.")
      (var result float64)
      (cond
       ((< s1 s2 string) (<- result -1.0))
       ((> s1 s2 string) (<- result +1.0))
       (nil (<- result +zero64)))
      (*/)
      (return result))
    
   
    (define (-string_match (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object
      (note "This function is generic and can be applied even if " (:local this) " is not a string.")
      (rwhen (in phase (tag compile))
        (throw-error -constant-error (:character-literal "match") " cannot be called from a constant expression"))
      (rwhen (/= (length args) 1)
        (throw-error -argument-error "exactly one argument must be supplied"))
      (const s string (object-to-string this phase))
      (todo))
    
   
    (define (-string_replace (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object
      (note "This function is generic and can be applied even if " (:local this) " is not a string.")
      (rwhen (in phase (tag compile))
        (throw-error -constant-error (:character-literal "replace") " cannot be called from a constant expression"))
      (rwhen (/= (length args) 2)
        (throw-error -argument-error "exactly two arguments must be supplied"))
      (const s string (object-to-string this phase))
      (todo))
    
   
    (define (-string_search (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object
      (note "This function is generic and can be applied even if " (:local this) " is not a string.")
      (rwhen (in phase (tag compile))
        (throw-error -constant-error (:character-literal "search") " cannot be called from a constant expression"))
      (rwhen (/= (length args) 1)
        (throw-error -argument-error "exactly one argument must be supplied"))
      (const s string (object-to-string this phase))
      (todo))
    
    
    (define (-string_slice (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) string
      (note "This function can be used in a constant expression if " (:local this) " and the arguments can be converted to primitives in constant expressions.")
      (note "This function is generic and can be applied even if " (:local this) " is not a string.")
      (rwhen (> (length args) 2)
        (throw-error -argument-error "at most two arguments can be supplied"))
      (const s string (object-to-string this phase))
      (const start-arg object (default-arg args 0 +zero64))
      (const end-arg object (default-arg args 1 +infinity64))
      (const start integer (pin-extended-integer (object-to-extended-integer start-arg phase) (length s) true))
      (const end integer (pin-extended-integer (object-to-extended-integer end-arg phase) (length s) true))
      (if (< start end)
        (return (subseq s start (- end 1)))
        (return "")))
    
   
    (define (-string_split (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object
      (note "This function is generic and can be applied even if " (:local this) " is not a string.")
      (rwhen (in phase (tag compile))
        (throw-error -constant-error (:character-literal "split") " cannot be called from a constant expression"))
      (rwhen (> (length args) 2)
        (throw-error -argument-error "at most two arguments can be supplied"))
      (const s string (object-to-string this phase))
      (todo))
    
    
    (define (-string_substring (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) string
      (note "This function can be used in a constant expression if " (:local this) " and the arguments can be converted to primitives in constant expressions.")
      (note "This function is generic and can be applied even if " (:local this) " is not a string.")
      (rwhen (> (length args) 2)
        (throw-error -argument-error "at most two arguments can be supplied"))
      (const s string (object-to-string this phase))
      (const start-arg object (default-arg args 0 +zero64))
      (const end-arg object (default-arg args 1 +infinity64))
      (const start integer (pin-extended-integer (object-to-extended-integer start-arg phase) (length s) false))
      (const end integer (pin-extended-integer (object-to-extended-integer end-arg phase) (length s) false))
      (if (<= start end)
        (return (subseq s start (- end 1)))
        (return (subseq s end (- start 1)))))
    
    
    (define (-string_to-lower-case (this object) (f simple-instance :unused) (args (vector object) :unused) (phase phase)) string
      (note "This function can be used in a constant expression if " (:local this) " can be converted to a primitive in a constant expression.")
      (note "This function is generic and can be applied even if " (:local this) " is not a string.")
      (const s string (object-to-string this phase))
      (const s32 (vector char21) (string-to-u-t-f32 s))
      (var r string "")
      (for-each s32 ch
        (<- r (append r (char-to-lower-full ch))))
      (return r))
    
    
    (define (-string_to-locale-lower-case (this object) (f simple-instance :unused) (args (vector object) :unused) (phase phase)) string
      (note "This function is generic and can be applied even if " (:local this) " is not a string.")
      (rwhen (in phase (tag compile))
        (throw-error -constant-error (:character-literal "toLocaleLowerCase") " cannot be called from a constant expression"))
      (const s string (object-to-string this phase))
      (const s32 (vector char21) (string-to-u-t-f32 s))
      (var r string "")
      (for-each s32 ch
        (<- r (append r (char-to-lower-localized ch))))
      (return r))
    
    
    (define (-string_to-upper-case (this object) (f simple-instance :unused) (args (vector object) :unused) (phase phase)) string
      (note "This function can be used in a constant expression if " (:local this) " can be converted to a primitive in a constant expression.")
      (note "This function is generic and can be applied even if " (:local this) " is not a string.")
      (const s string (object-to-string this phase))
      (const s32 (vector char21) (string-to-u-t-f32 s))
      (var r string "")
      (for-each s32 ch
        (<- r (append r (char-to-upper-full ch))))
      (return r))
    
    
    (define (-string_to-locale-upper-case (this object) (f simple-instance :unused) (args (vector object) :unused) (phase phase)) string
      (note "This function is generic and can be applied even if " (:local this) " is not a string.")
      (rwhen (in phase (tag compile))
        (throw-error -constant-error (:character-literal "toLocaleUpperCase") " cannot be called from a constant expression"))
      (const s string (object-to-string this phase))
      (const s32 (vector char21) (string-to-u-t-f32 s))
      (var r string "")
      (for-each s32 ch
        (<- r (append r (char-to-upper-localized ch))))
      (return r))
    
    
    
    (%heading (2 :semantics) "Array")
    (define -array class
      (new class
        (list-set-of local-binding)
        (%list-set-of instance-property
          (new instance-variable (list-set (new qualified-name array-private "length")) true false -number +zero64 false)
          (new instance-getter (list-set (new qualified-name public "length")) true false :uninit -array_get-length)
          (new instance-setter (list-set (new qualified-name public "length")) true false :uninit -array_set-length))
        -object (delay -array-prototype) true
        "Array" "object" array-private true true null hint-number
        ordinary-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read write-array ordinary-delete ordinary-enumerate
        same-as-construct ordinary-construct init-array ordinary-is ordinary-coerce))
    
    (define array-limit integer (/*/ (expt 2 53) "an implementation-defined integer value between " (:expr integer (- (expt 2 32) 1)) " and "
                                     (:expr integer (expt 2 53)) " inclusive"))
    (define array-private namespace (new namespace "private"))
    
    (define (write-array (o object) (limit class) (multiname multiname) (env environment-opt) (new-value object) (create-if-missing boolean) (phase (tag run)))
            (tag none ok)
      (const result (tag none ok) (ordinary-write o limit multiname env new-value create-if-missing phase))
      (when (in result (tag ok))
        (const i integer-opt (multiname-to-unsigned-integer multiname))
        (when (not-in i (tag none) :narrow-true)
          (rwhen (>= i array-limit)
            (throw-error -range-error "array index out of range"))
          (var length integer (read-array-private-length o phase))
          (when (>= i length)
            (<- length (+ i 1))
            (write-array-private-length o length phase))))
      (return result))
    
    (%text :comment (:global-call read-array-private-length array phase) " returns an " (:character-literal "Array") :apostrophe
           "s private length. See also " (:global read-length) ", which can work on non-" (:character-literal "Array") " objects.")
    (define (read-array-private-length (array object) (phase phase)) integer
      (const length float64 (assert-in (read-instance-slot array (new qualified-name array-private "length") phase) float64))
      (assert (not-in length (tag nan64 +infinity64 -infinity64) :narrow-true))
      (var n rational (to-rational length))
      (assert (and (in n integer :narrow-true) (cascade integer 0 <= n <= array-limit)))
      (return n))
    
    (%text :comment (:global-call write-array-private-length array length phase) " sets an " (:character-literal "Array") :apostrophe
           "s private length to " (:local length) " after ensuring that " (:local length) " is between 0 and " (:global array-limit)
           " inclusive. See also " (:global write-length) ", which can work on non-" (:character-literal "Array") " objects.")
    (define (write-array-private-length (array object) (length integer) (phase (tag run))) void
      (rwhen (or (< length 0) (> length array-limit))
        (throw-error -range-error "array length out of range"))
      (dot-write array (list-set (new qualified-name array-private "length")) (real-to-float64 length) phase))
    
    (define (multiname-to-unsigned-integer (multiname multiname)) integer-opt
      (rwhen (/= (length multiname) 1)
        (return none))
      (const qname qualified-name (unique-elt-of multiname))
      (rwhen (/= (& namespace qname) public namespace)
        (return none))
      (const name string (& id qname))
      (when (nonempty name)
        (cond
         ((= name "0" string) (return 0))
         ((and (/= (nth name 0) #\0 char16) (every name ch (set-in ch (range-set-of-ranges char16 #\0 #\9))))
          (return (assert-in (string-to-extended-integer name) integer)))))
      (return none))
    
    (define (init-array (this simple-instance) (args (vector object)) (phase (tag run))) void
      (when (= (length args) 1)
        (const arg object (nth args 0))
        (rwhen (in arg general-number :narrow-true)
          (const length integer-opt (check-integer arg))
          (rwhen (in length (tag none) :narrow-false)
            (throw-error -range-error "array length must be an integer"))
          (write-array-private-length this length phase)
          (return)))
      (var i integer 0)
      (for-each args arg
        (index-write this i arg phase)
        (<- i (+ i 1)))
      (note "The call to " (:global index-write) " above also set the array" :apostrophe "s length to " (:local i) "."))
    
    
    (define (-array_get-length (this object) (phase phase)) float64
      (assert (is this -array) (:assertion) " because this getter cannot be extracted from the " (:character-literal "Array") " class.")
      (note "An array" :apostrophe "s length is mutable, so reading it will throw " (:global -constant-error) " when " (:expr boolean (in phase (tag compile))) ".")
      (return (assert-in (read-instance-slot this (new qualified-name array-private "length") phase) float64)))
    
    (define (-array_set-length (this object) (length object) (phase phase)) void
      (assert (is this -array) (:assertion) " because this setter cannot be extracted from the " (:character-literal "Array") " class.")
      (quiet-assert (in this simple-instance :narrow-true))
      (rwhen (in phase (tag compile) :narrow-false)
        (throw-error -constant-error "an array" :apostrophe "s " (:character-literal "length") " cannot be set from a constant expression"))
      (const new-length integer-opt (check-integer (object-to-general-number length phase)))
      (rwhen (or (in new-length (tag none) :narrow-false) (< new-length 0) (> new-length array-limit))
        (throw-error -range-error "array length out of range or not an integer"))
      (const old-length integer (read-array-private-length this phase))
      (when (< new-length old-length)
        (note "Delete all indexed properties greater than or equal to the new length")
        (function (qname-in-deleted-range (qname qualified-name)) boolean
          (const i integer-opt (multiname-to-unsigned-integer (list-set qname)))
          (return (and (not-in i (tag none) :narrow-true) (cascade integer new-length <= i < old-length))))
        (&= local-bindings this
            (map (& local-bindings this)
                 b b (not (qname-in-deleted-range (& qname b))))))
      (write-array-private-length this new-length phase))
    
    
    (define -array-prototype simple-instance
      (new simple-instance
        (%list-set
         (std-const-binding (new qualified-name public "constructor") -class -array)
         (std-function (new qualified-name public "toString") -array_to-string 0)
         (std-function (new qualified-name public "toLocaleString") -array_to-locale-string 0)
         (std-function (new qualified-name public "concat") -array_concat 1)
         (std-function (new qualified-name public "join") -array_join 1)
         (std-function (new qualified-name public "pop") -array_pop 0)
         (std-function (new qualified-name public "push") -array_push 1)
         (std-function (new qualified-name public "reverse") -array_reverse 0)
         (std-function (new qualified-name public "shift") -array_shift 0)
         (std-function (new qualified-name public "slice") -array_slice 2)
         (std-function (new qualified-name public "sort") -array_sort 1)
         (std-function (new qualified-name public "splice") -array_splice 2)
         (std-function (new qualified-name public "unshift") -array_unshift 1))
        -object-prototype prototypes-sealed -object
        (list-set-of slot) none none none))
    ;***** Add some properties here
    
    
    (define (-array_to-string (this object) (f simple-instance :unused) (args (vector object) :unused) (phase phase)) string
      (rwhen (in phase (tag compile) :narrow-false)
        (throw-error -constant-error (:character-literal "toString") " cannot be called on an " (:character-literal "Array") " from a constant expression"))
      (note "This function is generic and can be applied even if " (:local this) " is not an " (:character-literal "Array") ".")
      (note "This function ignores any arguments passed to it in " (:local args) ".")
      (return (internal-join this "," phase)))
    
    
    (define (-array_to-locale-string (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) string
      (rwhen (in phase (tag compile) :narrow-false)
        (throw-error -constant-error (:character-literal "toLocaleString") " cannot be called on an " (:character-literal "Array") " from a constant expression"))
      (note "This function is generic and can be applied even if " (:local this) " is not an " (:character-literal "Array") ".")
      (note "This function passes any arguments passed to it in " (:local args) " to " (:character-literal "toLocaleString") " applied to the elements of the array.")
      (const separator string (/*/ "," "the list-separator string appropriate for the host" :apostrophe "s current locale, derived in an implementation-defined way"))
      (const length integer (read-length this phase))
      (var result string "")
      (var i integer 0)
      (while (/= i length)
        (const elt object-opt (index-read this i phase))
        (when (not-in elt (tag undefined null none) :narrow-true)
          (const to-locale-string-method object (dot-read elt (list-set (new qualified-name public "toLocaleString")) phase))
          (const s object (call elt to-locale-string-method args phase))
          (rwhen (not-in s (union char16 string) :narrow-false)
            (throw-error -type-error (:character-literal "toLocaleString") " should return a string"))
          (<- result (append result (to-string s))))
        (<- i (+ i 1))
        (when (/= i length)
          (<- result (append result separator))))
      (return result))
    
    
    (define (-array_concat (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object
      (rwhen (in phase (tag compile) :narrow-false)
        (throw-error -constant-error (:character-literal "concat") " cannot be called from a constant expression"))
      (note "This function is generic and can be applied even if " (:local this) " is not an " (:character-literal "Array") ".")
      (const constituents (vector object) (append (vector this) args))
      (const array object (construct -array (vector-of object) phase))
      (var i integer 0)
      (for-each constituents o
        (cond
         ((is o -array)
          (const o-length integer (read-length o phase))
          (var k integer 0)
          (while (/= k o-length)
            (const elt object-opt (index-read o k phase))
            (when (not-in elt (tag none) :narrow-true)
              (index-write array i elt phase))
            (<- k (+ k 1))
            (<- i (+ i 1))))
         (nil
          (index-write array i o phase)
          (<- i (+ i 1)))))
      (write-array-private-length array i phase)
      (return array))
    
    
    (define (-array_join (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) string
      (rwhen (in phase (tag compile) :narrow-false)
        (throw-error -constant-error (:character-literal "join") " cannot be called from a constant expression"))
      (note "This function is generic and can be applied even if " (:local this) " is not an " (:character-literal "Array") ".")
      (rwhen (> (length args) 1)
        (throw-error -argument-error "at most one argument can be supplied"))
      (const arg object (default-arg args 0 undefined))
      (var separator string ",")
      (when (not-in arg (tag undefined))
        (<- separator (object-to-string arg phase)))
      (return (internal-join this separator phase)))
    
    
    (define (internal-join (this object) (separator string) (phase (tag run))) string
      (const length integer (read-length this phase))
      (var result string "")
      (var i integer 0)
      (while (/= i length)
        (const elt object-opt (index-read this i phase))
        (when (not-in elt (tag undefined null none) :narrow-true)
          (<- result (append result (object-to-string elt phase))))
        (<- i (+ i 1))
        (when (/= i length)
          (<- result (append result separator))))
      (return result))
    
    
    (define (-array_pop (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object
      (rwhen (in phase (tag compile) :narrow-false)
        (throw-error -constant-error (:character-literal "pop") " cannot be called from a constant expression"))
      (note "This function is generic and can be applied even if " (:local this) " is not an " (:character-literal "Array") ".")
      (rwhen (/= (length args) 0)
        (throw-error -argument-error "no arguments can be supplied"))
      (var length integer (read-length this phase))
      (var result object undefined)
      (when (/= length 0)
        (<- length (- length 1))
        (const elt object-opt (index-read this length phase))
        (when (not-in elt (tag none) :narrow-true)
          (<- result elt)
          (index-write this length none phase)))
      (write-length this length phase)
      (return result))
    
    
    (define (-array_push (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object
      (rwhen (in phase (tag compile) :narrow-false)
        (throw-error -constant-error (:character-literal "push") " cannot be called from a constant expression"))
      (note "This function is generic and can be applied even if " (:local this) " is not an " (:character-literal "Array") ".")
      (var length integer (read-length this phase))
      (for-each args arg
        (index-write this length arg phase)
        (<- length (+ length 1)))
      (write-length this length phase)
      (return (real-to-float64 length)))
    
    
    (define (-array_reverse (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object
      (rwhen (in phase (tag compile) :narrow-false)
        (throw-error -constant-error (:character-literal "reverse") " cannot be called from a constant expression"))
      (note "This function is generic and can be applied even if " (:local this) " is not an " (:character-literal "Array") ".")
      (rwhen (/= (length args) 0)
        (throw-error -argument-error "no arguments can be supplied"))
      (const length integer (read-length this phase))
      (var lo integer 0)
      (var hi integer (- length 1))
      (while (< lo hi)
        (const lo-elt object-opt (index-read this lo phase))
        (const hi-elt object-opt (index-read this hi phase))
        (index-write this lo hi-elt phase)
        (index-write this hi lo-elt phase)
        (<- lo (+ lo 1))
        (<- hi (- hi 1)))
      (return this))
    
    
    (define (-array_shift (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object
      (rwhen (in phase (tag compile) :narrow-false)
        (throw-error -constant-error (:character-literal "shift") " cannot be called from a constant expression"))
      (note "This function is generic and can be applied even if " (:local this) " is not an " (:character-literal "Array") ".")
      (rwhen (/= (length args) 0)
        (throw-error -argument-error "no arguments can be supplied"))
      (var length integer (read-length this phase))
      (var result object undefined)
      (when (/= length 0)
        (var elt object-opt (index-read this 0 phase))
        (when (not-in elt (tag none) :narrow-true)
          (<- result elt))
        (var i integer 1)
        (while (/= i length)
          (<- elt (index-read this i phase))
          (index-write this (- i 1) elt phase)
          (<- i (+ i 1)))
        (<- length (- length 1))
        (index-write this length none phase))
      (write-length this length phase)
      (return result))
    
    
    (define (-array_slice (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object
      (rwhen (in phase (tag compile) :narrow-false)
        (throw-error -constant-error (:character-literal "slice") " cannot be called on an " (:character-literal "Array") " from a constant expression"))
      (note "This function is generic and can be applied even if " (:local this) " is not an " (:character-literal "Array") ".")
      (rwhen (> (length args) 2)
        (throw-error -argument-error "at most two arguments can be supplied"))
      (const length integer (read-length this phase))
      (const start-arg object (default-arg args 0 +zero64))
      (const end-arg object (default-arg args 1 +infinity64))
      (const start integer (pin-extended-integer (object-to-extended-integer start-arg phase) length true))
      (const end integer (pin-extended-integer (object-to-extended-integer end-arg phase) length true))
      (return (make-array-slice this start end phase)))
    
    (define (make-array-slice (array object) (start integer) (end integer) (phase (tag run))) object
      (const slice object (construct -array (vector-of object) phase))
      (var i integer start)
      (var j integer 0)
      (while (< i end)
        (const elt object-opt (index-read array i phase))
        (index-write slice j elt phase)
        (<- i (+ i 1))
        (<- j (+ j 1)))
      (write-length slice j phase)
      (return slice))

    
    (define (-array_sort (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object
      (rwhen (in phase (tag compile) :narrow-false)
        (throw-error -constant-error (:character-literal "sort") " cannot be called from a constant expression"))
      (note "This function is generic and can be applied even if " (:local this) " is not an " (:character-literal "Array") ".")
      (rwhen (> (length args) 1)
        (throw-error -argument-error "at most one argument can be supplied"))
      (todo))
    
    
    (define (-array_splice (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object
      (rwhen (in phase (tag compile) :narrow-false)
        (throw-error -constant-error (:character-literal "splice") " cannot be called from a constant expression"))
      (note "This function is generic and can be applied even if " (:local this) " is not an " (:character-literal "Array") ".")
      (rwhen (< (length args) 2)
        (throw-error -argument-error "at least two arguments must be supplied"))
      (const length integer (read-length this phase))
      (const start-arg object (default-arg args 0 +zero64))
      (const delete-count-arg object (default-arg args 1 +zero64))
      (const start integer (pin-extended-integer (object-to-extended-integer start-arg phase) length true))
      (const delete-count integer (pin-extended-integer (object-to-extended-integer delete-count-arg phase) (- length start) false))
      (const deleted-slice object (make-array-slice this start (+ start delete-count) phase))
      (const new-elts (vector object) (subseq args 2))
      (const new-elt-count integer (length new-elts))
      (const count-diff integer (- new-elt-count delete-count))
      (var i integer)
      (cond
       ((< count-diff 0)
        (<- i (+ start delete-count))
        (while (/= i length)
          (const elt object-opt (index-read this i phase))
          (index-write this (+ i count-diff) elt phase)
          (<- i (+ i 1)))
        (<- i 0)
        (while (/= i count-diff)
          (<- i (- i 1))
          (index-write this (+ length i) none phase)))
       ((> count-diff 0)
        (<- i length)
        (while (/= i (+ start delete-count))
          (<- i (- i 1))
          (const elt object-opt (index-read this i phase))
          (index-write this (+ i count-diff) elt phase))))
      (write-length this (+ length count-diff) phase)
      (<- i start)
      (for-each new-elts arg
        (index-write this i arg phase)
        (<- i (+ i 1)))
      (return deleted-slice))
    
    
    (define (-array_unshift (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) float64
      (rwhen (in phase (tag compile) :narrow-false)
        (throw-error -constant-error (:character-literal "unshift") " cannot be called from a constant expression"))
      (note "This function is generic and can be applied even if " (:local this) " is not an " (:character-literal "Array") ".")
      (var i integer (read-length this phase))
      (const n-args integer (length args))
      (const new-length integer (+ n-args i))
      (when (= n-args 0)
        (// "At the implementation" :apostrophe "s discretion, either do nothing or " (:keyword return) :nbsp (:expr float64 (real-to-float64 new-length))))
      (write-length this new-length phase)
      (while (/= i 0)
        (<- i (- i 1))
        (const elt object-opt (index-read this i phase))
        (index-write this (+ i n-args) elt phase))
      (for-each args arg
        (index-write this i arg phase)
        (<- i (+ i 1)))
      (return (real-to-float64 new-length)))
    
    
    
    (%heading (2 :semantics) "Namespace")
    (define -namespace class
      (new class
        (list-set-of local-binding) (list-set-of instance-property) -object (delay -namespace-prototype) true
        "Namespace" "namespace" :uninit false true null hint-string
        ordinary-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate
        ordinary-call construct-namespace none ordinary-is ordinary-coerce))
    
    (define (construct-namespace (c class :unused) (args (vector object)) (phase phase)) namespace
      (note "This function can be used in a constant expression if its argument is a string.")
      (rwhen (> (length args) 1)
        (throw-error -argument-error "at most one argument can be supplied"))
      (const arg object (default-arg args 0 undefined))
      (cond
       ((in arg (union null undefined))
        (rwhen (in phase (tag compile))
          (throw-error -constant-error "a constant expression cannot construct new anonymous namespaces"))
        (return (new namespace "anonymous")))
       ((in arg (union char16 string) :narrow-true)
        (const name string (to-string arg))
        (reserve ns)
        (cond
         ((= name "" string)
          (return public))
         ((some named-namespaces ns (= (& name ns) name string) :define-true)
          (return ns))
         (nil
          (const ns2 namespace (new namespace name))
          (<- named-namespaces (set+ named-namespaces (list-set ns2)))
          (return ns2))))
       (nil (throw-error -type-error))))
    
    (defvar named-namespaces (list-set namespace) (list-set-of namespace))
    
    (define -namespace-prototype simple-instance
      (new simple-instance
        (%list-set
         (std-function (new qualified-name public "toString") -namespace_to-string 0)
         (std-reserve (new qualified-name public "valueOf") -object-prototype))
        -object-prototype prototypes-sealed -object
        (list-set-of slot) none none none))
    
    
    (define (-namespace_to-string (this object) (f simple-instance :unused) (args (vector object) :unused) (phase phase :unused)) string
      (note "This function does not check " (:local phase) " and therefore can be used in a constant expression.")
      (note "This function ignores any arguments passed to it in " (:local args) ".")
      (rwhen (not-in this namespace :narrow-false)
        (throw-error -type-error))
      (return (& name this)))
    
    
    (%heading (2 :semantics) "Attribute")
    (define -attribute class
      (new class
        (list-set-of local-binding) (list-set-of instance-property) -object (delay -object-prototype) true
        "Attribute" "object" :uninit false true null hint-string
        ordinary-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate
        dummy-call dummy-construct none ordinary-is ordinary-coerce))
    
    
    (%heading (2 :semantics) "Date")
    (define -date class
      (new class
        (list-set-of local-binding) (list-set-of instance-property) -object (delay -date-prototype) true
        "Date" "object" :uninit true true null hint-string
        ordinary-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate
        dummy-call dummy-construct none ordinary-is ordinary-coerce))
    
    (define -date-prototype simple-instance
      (new simple-instance
        (list-set-of local-binding)
        -object-prototype prototypes-sealed -object
        (list-set-of slot) none none none))
    ;***** Add some properties here
    
    
    (%heading (2 :semantics) "RegExp")
    (define -reg-exp class
      (new class
        (list-set-of local-binding) (list-set-of instance-property) -object (delay -reg-exp-prototype) true
        "RegExp" "object" :uninit true true null hint-number
        ordinary-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate
        dummy-call dummy-construct none ordinary-is ordinary-coerce))
    
    (define -reg-exp-prototype simple-instance
      (new simple-instance
        (list-set-of local-binding)
        -object-prototype prototypes-sealed -object
        (list-set-of slot) none none none))
    ;***** Add some properties here
    
    
    (%heading (2 :semantics) "Class")
    (define -class class
      (new class
        (list-set-of local-binding)
        (list-set-of instance-property class-prototype-getter)
        -object (delay -class-prototype) true
        "Class" "function" :uninit false true null hint-string
        ordinary-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate
        dummy-call dummy-construct none ordinary-is ordinary-coerce))
    
    (define class-prototype-getter instance-getter (new instance-getter (list-set (new qualified-name public "prototype")) true false :uninit -class_prototype))
    (define (-class_prototype (this object) (phase phase :unused)) object
      (assert (in this class :narrow-true) (:assertion) " because this getter cannot be extracted from the " (:character-literal "Class") " class.")
      (const prototype object-opt (&opt prototype this))
      (if (in prototype (tag none) :narrow-false)
        (return undefined)
        (return prototype)))
    
    (define -class-prototype simple-instance
      (new simple-instance
        (%list-set
         (std-const-binding (new qualified-name public "constructor") -class -class)
         (std-function (new qualified-name public "toString") -class_to-string 0)
         (std-reserve (new qualified-name public "valueOf") -object-prototype)
         (std-const-binding (new qualified-name public "length") -number 1.0))
        -object-prototype prototypes-sealed -object
        (list-set-of slot) none none none))
    
    
    (define (-class_to-string (this object) (f simple-instance :unused) (args (vector object) :unused) (phase phase :unused)) string
      (note "This function does not check " (:local phase) " and therefore can be used in a constant expression.")
      (note "This function ignores any arguments passed to it in " (:local args) ".")
      (const c class (object-to-class this))
      (return (append "[class " (& name c) "]")))
    
    
    (%heading (2 :semantics) "Function")
    (define -function class
      (new class
        (list-set-of local-binding)
        (list-set-of instance-property ivar-function-length)
        -object (delay -function-prototype) true
        "Function" "function" :uninit false true null hint-string
        ordinary-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate
        dummy-call dummy-construct none ordinary-is ordinary-coerce))
    
    (define ivar-function-length instance-variable (new instance-variable (list-set (new qualified-name public "length")) true false -number none true))
    
    (define -function-prototype simple-instance
      (new simple-instance
        (list-set-of local-binding)
        -object-prototype prototypes-sealed -object
        (list-set-of slot) none none none))
    ;***** Add some properties here
    
    
    (%heading (3 :semantics) "PrototypeFunction")
    (define -prototype-function class
      (new class
        (list-set-of local-binding)
        (list-set-of instance-property
          (new instance-variable (list-set (new qualified-name public "prototype")) true false -object undefined false))
        -function (delay -function-prototype) true
        "Function" "function" :uninit true true null hint-string
        ordinary-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate
        dummy-call dummy-construct none ordinary-is ordinary-coerce)) ;***** Need to set prototype here.
    
    
    (%heading (2 :semantics) "Package")
    (define -package class
      (new class
        (list-set-of local-binding) (list-set-of instance-property) -object (delay -object-prototype) true
        "Package" "object" :uninit true true null hint-string
        ordinary-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate
        dummy-call dummy-construct none ordinary-is ordinary-coerce))
    
    
    (%heading (2 :semantics) "Error")
    (define -error class
      (new class
        (list-set-of local-binding)
        (%list-set-of instance-property
          (new instance-variable (list-set (new qualified-name public "name")) false true -string null false)
          (new instance-variable (list-set (new qualified-name public "message")) false true -string null false))
        -object (delay -error-prototype) true
        "Error" "object" :uninit true false null hint-number
        ordinary-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate
        call-error ordinary-construct init-error ordinary-is ordinary-coerce))
    
    (define (call-error (this object :unused) (c class) (args (vector object)) (phase phase)) object
      (rwhen (> (length args) 1)
        (throw-error -argument-error "at most one argument can be supplied"))
      (const arg object (default-arg args 0 undefined))
      (if (or (in arg (tag null)) (is arg -error))
        (return arg)
        (return (construct c args phase))))
    
    (define (init-error (this simple-instance) (args (vector object)) (phase (tag run))) void
      (rwhen (> (length args) 1)
        (throw-error -argument-error "at most one argument can be supplied"))
      (const name (union string null) (assert-in (dot-read -error-prototype (list-set (new qualified-name public "name")) phase) (union string null)))
      (dot-write this (list-set (new qualified-name public "name")) name phase)
      (const arg object (default-arg args 0 undefined))
      (var message (union string null))
      (if (in arg (tag undefined))
        (<- message (assert-in (dot-read -error-prototype (list-set (new qualified-name public "message")) phase) (union string null)))
        (<- message (object-to-string arg phase)))
      (dot-write this (list-set (new qualified-name public "message")) message phase))
    
    
    (define -error-prototype simple-instance
      (new simple-instance
        (%list-set
         (std-const-binding (new qualified-name public "constructor") -class -error)
         (std-function (new qualified-name public "toString") -error_to-string 1)
         (std-var-binding (new qualified-name public "name") -string "Error")
         (std-var-binding (new qualified-name public "message") -string (/*/ "ErrorPrototypeMessage" "an implementation-defined string")))
        -object-prototype prototypes-sealed -object
        (list-set-of slot) none none none))
    
    
    (define (-error_to-string (this object) (f simple-instance :unused) (args (vector object) :unused) (phase phase)) string
      (rwhen (in phase (tag compile))
        (throw-error -constant-error (:character-literal "toString") " cannot be called on an " (:character-literal "Error") " from a constant expression"))
      (note "This function ignores any arguments passed to it in " (:local args) ".")
      (const err object (coerce-non-null this -error))
      (const name (union string null) (assert-in (dot-read err (list-set (new qualified-name public "name")) phase) (union string null)))
      (const message (union string null) (assert-in (dot-read err (list-set (new qualified-name public "message")) phase) (union string null)))
      (return (/*/ (append (object-to-string name phase) ": " (object-to-string message phase))
                "an implementation-defined string derived from " (:local name) ", " (:local message) ", and optionally other properties of " (:local err))))
    
    
    
    ;***** Describe what I do.
    (define (system-error (e class) (msg (union string undefined))) object
      (return (construct e (vector-of object msg) run)))
    
    
    (%heading (3 :semantics) "Error Subclasses")
    (define (make-built-in-error-subclass (name string)) class
      (function (call (this object :unused) (c class) (args (vector object)) (phase phase)) object
        (rwhen (> (length args) 1)
          (throw-error -argument-error "at most one argument can be supplied"))
        (const arg object (default-arg args 0 undefined))
        (if (or (in arg (tag null)) (is arg -error))
          (return (coerce arg c))
          (return (construct c args phase))))
      (const c class
        (new class
          (list-set-of local-binding) (list-set-of instance-property) -error :uninit false
          name "object" :uninit true false null hint-number
          (& has-property -error) (& bracket-read -error) (& bracket-write -error) (& bracket-delete -error)
          (& read -error) (& write -error) (& delete -error)
          (& enumerate -error)
          call ordinary-construct none ordinary-is ordinary-coerce))
      (const prototype simple-instance
        (new simple-instance
          (%list-set
           (std-const-binding (new qualified-name public "constructor") -class c)
           (std-var-binding (new qualified-name public "name") -string name)
           (std-var-binding (new qualified-name public "message") -string (/*/ (append name "PrototypeMessage") "an implementation-defined string")))
          -error-prototype prototypes-sealed -object
          (list-set-of slot) none none none))
      (function (init (this simple-instance) (args (vector object)) (phase (tag run))) void
        (rwhen (> (length args) 1)
          (throw-error -argument-error "at most one argument can be supplied"))
        (const name2 (union string null) (assert-in (dot-read prototype (list-set (new qualified-name public "name")) phase) (union string null)))
        (dot-write this (list-set (new qualified-name public "name")) name2 phase)
        (const arg object (default-arg args 0 undefined))
        (var message (union string null))
        (if (in arg (tag undefined))
          (<- message (assert-in (dot-read prototype (list-set (new qualified-name public "message")) phase) (union string null)))
          (<- message (object-to-string arg phase)))
        (dot-write this (list-set (new qualified-name public "message")) message phase))
      (&const= prototype c prototype)
      (&= init c init)
      (&= complete c true)
      (return c))
    
    
    (define -argument-error class (make-built-in-error-subclass "ArgumentError"))
    (define -attribute-error class (make-built-in-error-subclass "AttributeError"))
    (define -constant-error class (make-built-in-error-subclass "ConstantError"))
    (define -definition-error class (make-built-in-error-subclass "DefinitionError"))
    (define -eval-error class (make-built-in-error-subclass "EvalError"))
    (define -range-error class (make-built-in-error-subclass "RangeError"))
    (define -reference-error class (make-built-in-error-subclass "ReferenceError"))
    (define -syntax-error class (make-built-in-error-subclass "SyntaxError"))
    (define -type-error class (make-built-in-error-subclass "TypeError"))
    (define -uninitialized-error class (make-built-in-error-subclass "UninitializedError"))
    (define -u-r-i-error class (make-built-in-error-subclass "URIError"))
    
    
    (? hide
      (%heading (1 :semantics) "Pretty Printing")
      
      (define (object-to-source (o object)) string
        (case o
          (:narrow (union undefined null boolean) (return (object-to-string o run)))
          (:narrow long (return (append (general-number-to-string o) "L")))
          (:narrow u-long (return (append (general-number-to-string o) "UL")))
          (:select (tag nan32) (return "NaN_f"))
          (:select (tag +zero32) (return "+0.0f"))
          (:select (tag -zero32) (return "-0.0f"))
          (:select (tag +infinity32) (return "Infinity_f"))
          (:select (tag -infinity32) (return "-Infinity_f"))
          (:narrow nonzero-finite-float32 (return (append (general-number-to-string o) "f")))
          (:select (tag nan64) (return "NaN"))
          (:select (tag +zero64) (return "+0.0"))
          (:select (tag -zero64) (return "-0.0"))
          (:select (tag +infinity64) (return "Infinity"))
          (:select (tag -infinity64) (return "-Infinity"))
          (:narrow nonzero-finite-float64 (return (general-number-to-string o)))
          (:narrow char16 (return (vector #\' o #\')))
          (:narrow string (return (append "\"" o "\"")))
          (:narrow namespace (return (append "Namespace \"" (object-to-string o run) "\"")))
          (:narrow compound-attribute (return (append "CompoundAttribute \"" (object-to-string o run) "\"")))
          (:narrow class (return (append "Class " (& name o))))
          (:narrow simple-instance (return (append "SimpleInstance \"" (object-to-string o run) "\"")))
          (:narrow method-closure (return "MethodClosure"))
          (:narrow date (return (append "Date \"" (object-to-string o run) "\"")))
          (:narrow reg-exp (return (append "RegExp \"" (object-to-string o run) "\"")))
          (:narrow package (return (append "Package \"" (object-to-string o run) "\""))))))
    
    ))


(defparameter *jw* (generate-world "J" *jw-source* '((js2 . :js2) (es4 . :es4) (hide . :hide))))
(defparameter *jg* (world-grammar *jw* 'code-grammar))
(ensure-lf-subset *jg*)
(forward-parser-states *jg*)
#+allegro (clean-grammar *jg*) ;Remove this line if you wish to print the grammar's state tables.

(defparameter *ew* nil)
(defparameter *eg* nil)

(defun compute-ecma-subset ()
  (unless *ew*
    (setq *ew* (generate-world "E" *jw-source* '((js2 . delete) (es4 . nil) (hide . :hide))))
    (setq *eg* (world-grammar *ew* 'code-grammar))
    (ensure-lf-subset *eg*)
    (forward-parser-states *eg*))
  (length (grammar-states *eg*)))


; Print a list of states that have both $REGULAR-EXPRESSION and either / or /= as valid lookaheads.
(defun show-regexp-and-division-states (grammar)
  (all-state-transitions
   #'(lambda (state transitions-hash)
       (when (and (gethash '$regular-expression transitions-hash)
                  (or (gethash '/ transitions-hash) (gethash '/= transitions-hash)))
         (format *error-output* "State ~S~%" state)))
   grammar))


; Return five values:
;   A list of terminals that may precede a $regular-expression terminal;
;   A list of terminals that may precede a $virtual-semicolon but not / or /= terminal;
;   A list of terminals that may precede a / or /= terminal;
;   The intersection of the $regular-expression and /|/= lists.
;   The intersection of the $regular-expression|$virtual-semicolon and /|/= lists.
;
; USE ONLY ON canonical-lr-1 grammars.
; DON'T RUN THIS AFTER CALLING forward-parser-states.
(defun show-regexp-and-division-predecessors (grammar)
  (let* ((nstates (length (grammar-states grammar)))
         (state-predecessors (make-array nstates :element-type 'terminalset :initial-element *empty-terminalset*)))
    (dolist (state (grammar-states grammar))
      (dolist (transition-pair (state-transitions state))
        (let ((transition (cdr transition-pair)))
          (when (eq (transition-kind transition) :shift)
            (terminalset-union-f (svref state-predecessors (state-number (transition-state transition)))
                                 (make-terminalset grammar (car transition-pair)))))))
    (let ((regexp-predecessors *empty-terminalset*)
          (virtual-predecessors *empty-terminalset*)
          (div-predecessors *empty-terminalset*))
      (all-state-transitions
       #'(lambda (state transitions-hash)
           (let ((predecessors (svref state-predecessors (state-number state))))
             (when (gethash '$regular-expression transitions-hash)
               (terminalset-union-f regexp-predecessors predecessors))
             (if (or (gethash '/ transitions-hash) (gethash '/= transitions-hash))
               (terminalset-union-f div-predecessors predecessors)
               (when (gethash '$virtual-semicolon transitions-hash)
                 (terminalset-union-f virtual-predecessors predecessors)))))
       grammar)
      (values
       (terminalset-list grammar regexp-predecessors)
       (terminalset-list grammar virtual-predecessors)
       (terminalset-list grammar div-predecessors)
       (terminalset-list grammar (terminalset-intersection regexp-predecessors div-predecessors))
       (terminalset-list grammar (terminalset-intersection (terminalset-union regexp-predecessors virtual-predecessors) div-predecessors))))))


(defun depict-js-terminals (markup-stream grammar heading)
  (labels
    ((production-first-terminal (production)
       (first (production-rhs production)))
     
     (terminal-bin (terminal)
       (if (and terminal (symbolp terminal))
         (let ((name (symbol-name terminal)))
           (if (> (length name) 0)
             (let ((first-char (char name 0)))
               (cond
                ((char= first-char #\$) 0)
                ((not (or (char= first-char #\_) (alphanumericp first-char))) 1)
                ((member terminal (rule-productions (grammar-rule grammar :identifier)) :key #'production-first-terminal) 5)
                (t 3)))
             1))
         1))
     
     (depict-terminal-bin (bin-name bin-terminals)
       (when bin-terminals
         (depict-paragraph (markup-stream :body-text)
           (depict markup-stream bin-name)
           (depict-list markup-stream #'depict-terminal bin-terminals :separator " ")))))
    
    (let* ((bins (make-array 6 :initial-element nil))
           (all-terminals (grammar-terminals grammar))
           (terminals (remove-if #'lf-terminal? all-terminals)))
      (assert-true (= (length all-terminals) (1- (* 2 (length terminals)))))
      (setf (svref bins 2) (list '&&= '^^ '^^= '\|\|=))
      (setf (svref bins 4) (list 'abstract 'class 'const 'debugger 'enum 'export 'extends 'goto 'implements 'import
                                 'instanceof 'interface 'native 'package 'private 'protected 'public 'super 'synchronized
                                 'throws 'transient 'volatile))
      ; Used to be reserved in JavaScript 1.5: 'boolean 'byte 'char 'double 'float 'int 'long 'short
      (do ((i (length terminals)))
          ((zerop i))
        (let ((terminal (aref terminals (decf i))))
          (unless (eq terminal *end-marker*)
            (setf (svref bins 2) (delete terminal (svref bins 2)))
            (setf (svref bins 4) (delete terminal (svref bins 4)))
            (push terminal (svref bins (terminal-bin terminal))))))
      (depict-paragraph (markup-stream heading)
        (depict-link (markup-stream :definition "terminals" "" nil)
          (depict markup-stream "Terminals")))
      (mapc #'depict-terminal-bin '("General tokens: " "Punctuation tokens: " "Future punctuation tokens: "
                                    "Reserved words: " "Future reserved words: " "Non-reserved words: ")
            (coerce bins 'list)))))


(defun dump-parser ()
  (values
   (length (grammar-states *jg*))
   (depict-rtf-to-local-file
    "JS20/ParserGrammarJS2.rtf"
    "JavaScript 2.0 Syntactic Grammar"
    #'(lambda (markup-stream)
        (depict-js-terminals markup-stream *jg* :heading1)
        (depict-world-commands markup-stream *jw* :visible-semantics nil)))
   (depict-rtf-to-local-file
    "JS20/ParserSemanticsJS2.rtf"
    "JavaScript 2.0 Syntactic Semantics"
    #'(lambda (markup-stream)
        (depict-js-terminals markup-stream *jg* :heading1)
        (depict-world-commands markup-stream *jw*)))
   (compute-ecma-subset)
   (depict-rtf-to-local-file
    "JS20/ParserGrammarES4.rtf"
    "ECMAScript Edition 4 Syntactic Grammar"
    #'(lambda (markup-stream)
        (depict-js-terminals markup-stream *eg* :heading1)
        (depict-world-commands markup-stream *ew* :visible-semantics nil)))
   (depict-rtf-to-local-file
    "JS20/ParserSemanticsES4.rtf"
    "ECMAScript Edition 4 Syntactic Semantics"
    #'(lambda (markup-stream)
        (depict-js-terminals markup-stream *eg* :heading1)
        (depict-world-commands markup-stream *ew*)))
   
   (length (grammar-states *jg*))
   (depict-html-to-local-file
    "JS20/ParserGrammarJS2.html"
    "JavaScript 2.0 Syntactic Grammar"
    t
    #'(lambda (markup-stream)
        (depict-js-terminals markup-stream *jg* :heading2)
        (depict-world-commands markup-stream *jw* :heading-offset 1 :visible-semantics nil))
    :external-link-base "notation.html")
   (depict-html-to-local-file
    "JS20/ParserSemanticsJS2.html"
    "JavaScript 2.0 Syntactic Semantics"
    t
    #'(lambda (markup-stream)
        (depict-js-terminals markup-stream *jg* :heading1)
        (depict-world-commands markup-stream *jw*))
    :external-link-base "notation.html")
   (compute-ecma-subset)
   (depict-html-to-local-file
    "JS20/ParserGrammarES4.html"
    "ECMAScript Edition 4 Syntactic Grammar"
    t
    #'(lambda (markup-stream)
        (depict-js-terminals markup-stream *eg* :heading2)
        (depict-world-commands markup-stream *ew* :heading-offset 1 :visible-semantics nil))
    :external-link-base "notation.html")
   (depict-html-to-local-file
    "JS20/ParserSemanticsES4.html"
    "ECMAScript Edition 4 Syntactic Semantics"
    t
    #'(lambda (markup-stream)
        (depict-js-terminals markup-stream *eg* :heading1)
        (depict-world-commands markup-stream *ew*))
    :external-link-base "notation.html")))


#|
(dump-parser)

(depict-rtf-to-local-file
 "JS20/ParserSemanticsJS2.rtf"
 "JavaScript 2.0 Syntactic Semantics"
 #'(lambda (markup-stream)
     (depict-js-terminals markup-stream *jg* :heading1)
     (depict-world-commands markup-stream *jw*)))

(depict-html-to-local-file
 "JS20/ParserSemanticsJS2.html"
 "JavaScript 2.0 Syntactic Semantics"
 t
 #'(lambda (markup-stream)
     (depict-js-terminals markup-stream *jg* :heading1)
     (depict-world-commands markup-stream *jw*))
 :external-link-base "notation.html")


(with-local-output (s "JS20/ParserGrammarJS2 states") (print-grammar *jg* s))
(compute-ecma-subset)
(with-local-output (s "JS20/ParserGrammarES4 states") (print-grammar *eg* s))
|#

(length (grammar-states *jg*))